perm filename ILISP.MAC[UCI,SYS]1 blob
sn#049043 filedate 1973-07-03 generic text, type T, neo UTF8
00050 SUBTTL AC DEFINITIONS AND EXTERNALS --- PAGE 1
00100 TITLE ILISP INTERPRETER
00150 TWOSEG
00200 ;SYSPRG==667 ;PPN OF LISP SYSTEM - SET TO 0 FOR SYS:
00250 ;SYSPN==2 ;SAME HERE
00300 IFNDEF SYSPRG,<SYSPRG==0
00350 SYSPN==0>
00400 ;ALVINE==1 ;1 FOR ALVINE, 0 FOR NO ALVINE
00450 IFNDEF ALVINE,<ALVINE==0>
00500 ;HASH==1 ;1 FOR SETTING # OF HASH BUCKETS AT SYS. INIT. TIME
00550 IFNDEF HASH,<HASH==0>
00600 ;STPGAP==1 ;1 FOR STOPGAP, 0 TO DELETE IT
00650 IFNDEF STPGAP,<STPGAP==0>
00700 IF1,<PURGE CDR,DF>
00750 STANSW==1 ;1 FOR STANFORD, 0 FOR CHRISTIANS
00800 IFNDEF STANSW,<STANSW==0>
00850
00900 MLON
00950 INUMIN=377777
01000 INUM0=<INUMIN+777777>/2
01050 BCKETS==177
01100 IFE SYSPRG,<DEFINE SYSDEV <SIXBIT /SYS/>>
01150 IFN SYSPRG,<DEFINE SYSDEV <SIXBIT /DSK/>>
01200 DEFINE SYSNAM <SIXBIT /ILISP2/> ; *** MJC
01250
01300 ;accumulator definitions
01350 ;`sacred' means sacred to the interpreter
01400 ;`marked' means marked from by the garbage collector
01450 ;`protected' means protected during garbage collection
01500
01550 NIL=0 ;sacred, marked, protected ;atom head of NIL
01600 A=1 ;marked, protected ;results of functions and first arg of subrs
01650 B=A+1 ;marked, protected ;second arg of subrs
01700 C=B+1 ;marked, protected ;third arg of subrs
01750 AR1=4 ;marked, protected ;fourth arg of subrs
01800 AR2A=5 ;marked, protected ;fifth arg of subrs
01850 T=6 ;marked, protected ;minus number of args in LSUBR call
01900 TT=7 ;marked, protected
01950 REL=10 ;marked, protected
02000 S=11 ;$$NOW USED FOR ATOM RELOCATION AND GARBAGE COLLECTOR
02050 D=12
02100 R=13 ;protected
02150 P=14 ;sacred, protected ;regular push down stack pointer
02200 F=15 ;sacred ;free storage list pointer
02250 FF=16 ;sacred ;full word list pointer
02300 SP=17 ;sacred, protected ;special pushdown stack pointer
02350
02400 NACS==5 ;number of argument acs
02450
02500 X==0 ;X indicates impure (modified) code locations
02550 TEN==↑D10
02600
02650 ;UUO definitions
02700 ;UUOs used to call functions from compiled code
02750 ;the number of arguments is given by the ac field
02800 ;the address is a pointer either to the function
02850 ;name or the code of the function
02900 OPDEF FCALL [34B8] ;ordinary function call-may be changed to PUSHJ
02950 OPDEF JCALL [35B8] ;terminal function call-may be changed to JRST
03000 OPDEF CALLF [36B8] ;like call but may not be changed to PUSHJ
03050 OPDEF JCALLF [37B8] ;like jcall but may not be changed to JRST
03100 ;error UUOs
03150
03200 OPDEF ERR1 [1B8] ;ordinary lisp error ;gives backtrace
03250 OPDEF ERR2 [2B8] ;space overflow error ;no backtrace
03300 OPDEF ERR3 [3B8] ;ill. mem. ref.
03350 OPDEF STRTIP [4B8] ;print error message and continue
03400 ;system UUOs
03450
03500 OPDEF TTYUUO [51B8]
03550 OPDEF INCHRW [TTYUUO 0,]
03600 OPDEF OUTCHR [TTYUUO 1,]
03650 OPDEF OUTSTR [TTYUUO 3,]
03700 OPDEF INCHWL [TTYUUO 4,]
03750 OPDEF INCHSL [TTYUUO 5,]
03800 OPDEF CLRBFI [TTYUUO 11,]
03850 OPDEF SKPINC [TTYUUO 13,]
03900 OPDEF TALK [PUSHJ P,TTYCLR] ;this is to turn off control O.
03950 ;when ttyser lets you do this
04000 ;easily, change me
04050
04100 ;I/O bits and constants
04150 TTYLL==105 ;teletype linelength
04200 LPTLL==160 ;line printer linelength
04250 MLIOB==203 ;max length of I/O buffer
04300 NIOB==2 ;no of I/O buffers per device
04350 NIOCH==17 ;number of I/O channels
04400 FSTCH==1 ;first I/O channel
04450 TTCH==0 ;teletype I/O channel
04500 BLKSIZE==NIOB*MLIOB+COUNT+1
04550 INB==2
04600 OUTB==1
04650 AVLB==40
04700 DIRB==4
04750
04800 ;special ASCII characters
04850 ALTMOD==175
04900 SPACE==40 ;space
04950 IGCRLF==31 ;ignored cr-lf
05000 RUBOUT==177
05050 LF==12
05100 CR==15
05150 TAB==11
05200 BELL==7
05250 DBLQT==42 ;double quote "
05300
05350 ;byte pointer field definitions
05400 ACFLD==14 ;ac field
05450 XFLD==21 ;index field
05500 OPFLD==10 ;opcode field
05550 ADRFLD==43 ;adress field
05600
05650 ;external and internal symbols
05700
05750 EXTERNAL JOB41 ;instruction to be executed on UUO
05800 EXTERNAL JOBAPR ;address of APR interupt routines
05850 EXTERNAL JOBCNI ;interupt condition flags
05900 EXTERNAL JOBFF ;first location beyond program
05950 EXTERNAL JOBREL ;address of last legal instruction in core image
06000 EXTERNAL JOBREN ;reentry address
06050 EXTERNAL JOBSA ;starting address
06100 EXTERNAL JOBSYM ;address of symbol table
06150 EXTERNAL JOBTPC ;program counter at time of interupt
06200 EXTERNAL JOBUUO ;uuo is put here with effective address computed
06250 EXTERNAL JOBOPC ;$$FOR NEW REENTER FEATURES
06300 EXTERNAL JOBHRL ;HIGH SEGMENT BOUNDARY
06350
06400
06450 ;apr flags
06500 PDOV==200000 ;push down list overflow
06550 MPV==20000 ;memory protection violation
06600 NXM==10000 ;non-existant memory referenced
06650 APRFLG==PDOV+MPV+NXM ;any of the above
06700
06750 ;RE-ENTER CONTROL CHARACTERS
06800 CNTLH==10
06850 CNTLE==5
06900 CNTLB==2
06950 CNTLZ==32
07000 CNTLG==7
07050
07100 ;system uuos
07150 APRINI==16
07200 RESET==0
07250 STIME==27
07300 DEVCHR==4
07350 EXIT==12
07400 CORE==11
07450 SETUWP==36
07500 GETSEG==40
07550 ;REMOTE MACRO
07600
07650 DEFINE REMOTE (TX)
07700 < HERE1 <TX>>
07750
07800 DEFINE HERE1 (NEW,OLD,%G)
07850 < DEFINE %G
07900 < NEW>
07950 DEFINE REMOTE (TX)
08000 < HERE1 <TX>,<OLD
08050 %G
08100 >>>
08150 DEFINE HERE
08200 < DEFINE HERE1 (XX,YY)
08250 < YY>
08300 REMOTE>
08350 SALL
08400 SUBTTL TOP LEVEL AND INITIALIZATION --- PAGE 2
08450 PAGE
08500
08550 SHRST==400000
08600 RELOC SHRST
08650 REMOTE<
08700 LISPGO: SKIPE GCFLG ;$$CHECK FO GARBAGE COLLECTION
08750 PUSHJ P,GCING ;$$QUEUE THE REQUEST
08800 ; CAME 0,STNIL ;$$UNBIND STACK IF REGS LOOK OK *** MJC
08850 ; JRST GETHGH ;GO GET HIGH SEGMENT *** MJC
08900 ; MOVE B,SC2 *** MJC
08950 ; PUSHJ P,UBD ;$$UNBIND STACK *** MJC
09000 ; JRST STRT ;go to re-allocator *** MJC
09050 ;GETHGH: CALLI RESET *** MJC
09100 ; MOVSI A,1 *** MJC
09150 ;IFE STANSW,< CALLI A,CORE ;ELIMINATE ANY OLD HIGH SEGS. *** MJC
09200 ; HALT > *** MJC
09250 ;*** IFN STANSW,< CALLI A,400015
09300 ;*** HALT>
09350 ;*** MOVEI A,HGHDAT
09400 ;*** CALLI A,GETSEG ;GET THE PROPER HIGH SEG
09450 ;*** HALT
09500 MOVE A,HGHDAT+1 ; Get high segment name *** MJC
09550 CALLI A,400016 ; Attach to high seg if poss. *** MJC
09600 CAIN A,4 ; If err=4 (seg alrdy there) ok too *** MJC
09650 JRST SGPROT ; Success! *** MJC
09700
09750 CALLI 400017 ; Detach stray segments. *** MJC
09800 MOVE A,HGHDAT ; Get device name for OPEN. *** MJC
09850 MOVEM A,INTDAT+1 ; Move into parm list for OPEN. *** MJC
09900 OPEN 0,INTDAT ; Init ch 0 to dump mode. *** MJC
09950 JRST NOSEG ; Couldn't do it? *** MJC
10000 MOVE A,SGPPPN ; Get ppn of high seg file. *** MJC
10050 MOVEM A,HGHDAT+4 ; Store for LOOKUP. *** MJC
10100 LOOKUP 0,HGHDAT+1 ; Find file containing high seg *** MJC
10150 JRST NOSEG ; No high seg file -- collapse *** MJC
10200 HLRE A,HGHDAT+4 ; Ppn was replaced by -length *** MJC
10250 MOVNS A ; Fix up for CORE2. *** MJC
10300 CALLI A,400015 ; Grab core for high segment. *** MJC
10350 JRST NOSEG ; Can't get it? *** MJC
10400 MOVE A,HGHDAT+1 ; Name the high segment. *** MJC
10450 CALLI A,400036 ; SEGNM2 uuo. *** MJC
10500 JRST NOSEG ; Pretty weird. *** MJC
10550 MOVEI A,SHRST-1 ; For dump mode input. *** MJC
10600 HRRM A,HGHDAT+4 ; *** MJC
10650 INPUT 0,HGHDAT+4 ; Fill high seg with goodies. *** MJC
10700 CLOSE 0,1 ; Destroy fingerprints. *** MJC
10750 SGPROT: MOVEI A,DEBUGO ;SET THE REE ADDRESS
10800 HRRM A,JOBREN
10850 MOVE A,HGHDAT+1 ; Decide whether or not to *** MJC
10900 CAME A,[SYSNAM] ; protect segment. *** MJC
10950 JRST STRT ; Segment was not system's *** MJC
11000 CALLI 36 ; Write-protect segment. *** MJC
11050 HALT ; rather than turn him loose. *** MJC
11100 JRST STRT ;GO TO ALLOCATE STORAGE
11150 NOSEG: OUTSTR [ASCIZ/CAN'T GET HIGH SEGMENT!/] ; *** MJC
11200 HALT ; *** MJC
11250 HGHDAT: SYSDEV ; All used by LOOKUP and ENTER *** MJC
11300 SYSNAM ; High segment job & file name *** MJC
11350 0 ; High seg file extension. *** MJC
11400 0
11450 0 ; PRG,PPN of high seg file. *** MJC
11500 ; Also file length after LOOKUP *** MJC
11550 ; Used as dump wd cmd list. *** MJC
11600 0
11650 INTDAT: 17 ; Data mode. *** MJC
11700 SYSDEV ; Dev name (defd before OPEN) *** MJC
11750 0 ; Buffer indicators (none) *** MJC
11800 SGPPPN: XWD SYSPRG,SYSPN ; High seg file area *** MJC
11850 PATCHL: BLOCK 20
11900 >
11950
12000
12050 DDT: SETOM ERINT ;$$SET CONTROL H WITHOUT GOING THRU REE
12100 JRST @JOBOPC ;$$AND CONTINUE
12150
12200 DEBUGO: SKIPE GCFLG# ;CHECK GARBASE COLLECT.
12250 PUSHJ P,GCING ;QUEUE INTERRUPT
12300 INCHRW 0 ;READ THE CONTROL CHARACTER
12350 CAIN 0,CNTLH
12400 JRST [MOVE 0,STNIL
12450 JRST DDT]
12500 CAIN 0,CNTLE
12550 JRST [MOVE 0,STNIL
12600 MOVEI 1,NIL
12650 JRST ERR]
12700 CAIN 0,CNTLB
12750 JRST [MOVE 0,STNIL
12800 SETOM ERINT
12850 PUSHJ P,SPDLPT
12900 PUSHJ P,SPREDO
12950 JRST LSPRET]
13000 CAIN 0,CNTLZ
13050 JRST [MOVE 0,STNIL
13100 JRST LSPRET]
13150 CAIN 0,CNTLG
13200 JRST [MOVE 0,STNIL
13250 JRST RERX]
13300 JRST DEBUGO+2 ;NOT A CONTROL CHARACTER
13350 ;MUST BE SOMETHING IN THE BUFFER SO TRY AGAIN
13400
13450 START: CALLI RESET ;random initializations for lisp interupts
13500 MOVE [JSR UUOH]
13550 MOVEM JOB41
13600 MOVEI APRINT
13650 MOVEM JOBAPR
13700 MOVEI APRFLG
13750 CALLI APRINI
13800 SETZM GCFLG
13850 HRRZI 17,1
13900 IFN ALVINE,<SETZB 0,PSAV1>
13950 IFE ALVINE,<SETZ 0,>
14000 BLT 17,17 ;clear acs
14050 MOVE S,ATMOV ;$$SET UP RELOCATION FOR INTERNAL ATOMS (FOOLIST)
14100 LSPRT1: SETZM BIOCHN(S) ;$$CLEAR VARS FOR BREAK PACKAGE
14150 SETZM BPMPT(S) ;$$(#%IOCHNAS%#, #%PROMPTS%#, AND #%INDENT)
14200 MOVEI A,INUM0
14250 MOVEM A,BINDNT(S)
14300 SETZM ERINT# ;$$TURN OFF INTERRUPT FLAG
14350 SETOM ERRSW ;print error messages
14400 CLEARM ERRTN# ;return to top level on errors
14450 SETOM PRVCNT# ;initialize counter for errio
14500 MOVE P,C2# ;initial reg pdl ptr
14550 MOVE SP,SC2# ;initial spec pdl ptr
14600
14650
14700 MOVE A,LSPRMP# ;$$INITIALIZE TO TOP LEVEL PROMPT
14750 ;$$CAN BE CHANGED BY INITPROMPT
14800 PUSHJ P,PROMPT ;$$
14850
14900 SETZM SMAC ;$$CLEAR SPLICE LIST (JUST IN CASE)
14950 MOVE S,ATMOV ;$$SET UP RELOCATION FOR INTERNAL ATOMS (FOOLIST)
15000 PUSHJ P,TTYRET ;(outc nil t)(inc nil t)return output for gc message
15050 HRROI 0,CNIL2(S) ;initialize nil
15100 MOVEM 0,STNIL# ;$$SAVE FOR REG CHECK AT START TIME
15150 IFN HASH,<
15200 SKIPE HASHFG#
15250 JRST REHASH ;rehash if necessary>
15300 SKIPN F
15350 PUSHJ P,AGC ;garbage collect only if necessary
15400 SKIPN BSFLG# ;initial bootstrap for macros
15450 JRST BOOTS
15500 SKIPE A,INITF
15550 CALLF (A) ;evaluate initialization function
15600 PUSHJ P,TTYRET ;return all i/o to tty
15650 PUSHJ P,TERPRI
15700 SKIPE GOBF# ;garbaged oblist flag
15750 STRTIP [SIXBIT /GARBAGED OBLIST←!/]
15800 SETZM GOBF
15850 SKIPE BPSFLG#
15900 JRST BINER2 ;binary program space exceeded by loader
15950 LISP1: MOVE S,ATMOV# ;$$MAKE SURE REL STAYS
16000 ;$$SET UP - BELT AND SUSPENDERS TECHNIQUE
16050 PUSHJ P,READ ;this is the top level of lisp
16100 PUSHJ P,EVAL
16150 PUSHJ P,PRINT
16200 PUSHJ P,TERPRI
16250 JRST LISP1
16300 PAGE
16350 INITFN: EXCH A,INITF#
16400 POPJ P,
16450
16500 ;return from lisp error
16550 LSPRET: PUSHJ P,TERPRI
16600 MOVE B,SC2 ;RETURN FROM BELL
16650 PUSHJ P,UBD ;unbind specpdl
16700 JRST LSPRT1
16750
16800 .RSET: EXCH A,RSTSW#
16850 POPJ P,
16900
16950 ;BOOTSTRAPPER FOR USER'S INIT FILE
17000 BOOTS: SETOM BSFLG
17050 MOVE A,[POINT 7,[ASCII /(ERRSET[INC(INPUT DSK:(INIT.LSP]NIL)[(EVAL(READ]/]]
17100 MOVEM A,BOOPT#
17150 MOVEI A,BSTYI
17200 PUSHJ P,READP1
17250 PUSHJ P,EVAL
17300 JUMPE A,BOOTOT
17350 MOVEI A,BSTYI
17400 PUSHJ P,READP1
17450 PUSH P,A
17500 MOVE A,(P)
17550 PUSHJ P,ERRSET
17600 CAIE A,$EOF$(S)
17650 JRST .-3
17700 BOOTOT: PUSHJ P,EXCISE
17750 JRST ERR
17800
17850 BSTYI: ILDB A,BOOPT
17900 POPJ P,
17950 PAGE
18000 SUBTTL APR INTERRUPT ROUTINES --- PAGE 3
18050 ;arithmetic processor interupts
18100 ;mem. protect. violation, nonex. mem. or pdl overflow
18150
18200 APRINT: MOVE R,JOBCNI ;get interupt bits
18250 TRNE R,MPV+NXM ;what kind
18300 ERR3 @JOBTPC ;an ill mem ref-will become JRST ILLMEM
18350 JUMPN NIL,MES21 ;a pdl overflow
18400 STRTIP [SIXBIT /←PDL OVERFLOW FROM GC - CAN'T CONTINUE!/]
18450 JRST START
18500
18550 MES21: SETZM JOBUUO
18600 SKIPL P
18650 STRTIP [SIXBIT /←REG !/]
18700 SKIPL SP
18750 STRTIP [SIXBIT /←SPEC !/]
18800 SKIPE JOBUUO
18850 SPDLOV: ERR2 [SIXBIT /PUSHDOWN CAPACITY EXCEEDED !/]
18900 TRNE R,PDOV
18950 SKIPE JOBUUO
19000 HALT ;lisp should not be here
19050 BINER2: SETZM BPSFLG
19100 ERR2 [SIXBIT /BINARY PROGRAM SPACE EXCEEDED !/]
19150
19200 ILLMEM: LDB R,[POINT 4,@JOBTPC,XFLD] ;get index field of bad word
19250 CAIE R,F ;does it contain f
19300 ERR3 @JOBTPC ;no! error
19350 PUSHJ P,AGC ;yes! garbage collect
19400 JRST @JOBTPC ;and continue
19450 SUBTTL UUO HANDLER AND SUBR CALL ROUTINES --- PAGE 4
19500
19550 UUOMIN==1
19600 UUOMAX==4
19650
19700 REMOTE<UUOH: X ;jsr location
19750 JRST UUOH2>
19800 UUOH2: MOVEM T,TSV#
19850 MOVEM TT,TTSV#
19900 LDB T,[POINT 9,JOBUUO,OPFLD] ;get opcode
19950 CAIGE T,34 ;is it a function call
20000 JRST ERROR ;or a LISP error
20050 HLRE R,@JOBUUO
20100 AOJN R,UUOS
20150 LDB T,[POINT 4,JOBUUO,ACFLD]
20200 CAILE T,15
20250 MOVEI R,-15(T)
20300 HRRZ T,@JOBUUO
20350 UUOH1: HLRZ TT,(T)
20400 HRRZ T,(T)
20450 CAIN TT,SUBR(S)
20500 JRST @UUST(R)
20550 CAIN TT,FSUBR(S)
20600 JRST @UUFST(R)
20650 CAIN TT,LSUBR(S)
20700 JRST @UULT(R)
20750 CAIN TT,EXPR(S)
20800 JRST @UUET(R)
20850 CAIN TT,FEXPR(S)
20900 JRST @UUFET(R)
20950 HRRZ T,(T)
21000 JUMPN T,UUOH1
21050 PUSH P,A
21100 PUSH P,B
21150 HRRZ A,JOBUUO
21200 MOVEI B,VALUE(S)
21250 PUSHJ P,GET
21300 JUMPN A,[ HRRZ TT,(A)
21350 POP P,B
21400 POP P,A
21450 JRST UUOEX1]
21500 HRRZ A,JOBUUO
21550 PUSHJ P,EPRINT
21600 ERR1 [SIXBIT /UNDEFINED UUO!/]
21650 PAGE
21700 SKIPA T,TT
21750 UUOSBR: HLRZ T,(T)
21800 MOVE TT,JOBUUO
21850 HRLI T,(PUSHJ P,)
21900 TLNE TT,1000 ;1000 means no push
21950 TLCA T,34600 ;<PUSHJ P,>xor<JRST>
22000 PUSH P,UUOH
22050 SOS UUOH
22100 HRRZ D,UUOH
22150 CAIG D,SHRST
22200 JRST .+3
22250 SKIPE WRTSTS
22300 JRST .+3
22350 REMOTE<UUOCL: TLNN TT,2000> ;2000 means no clobber
22400 XCT UUOCL
22450 MOVEM T,@UUOH
22500 MOVE TT,TTSV
22550 EXCH T,TSV
22600 JRST @TSV
22650
22700 UUOS: HRRZ TT,JOBUUO
22750 CAILE TT,@GCPP1
22800 CAIL TT,@GCP1
22850 JRST UUOSBR-1
22900 JRST .+2
22950 UUOEXP: HLRZ TT,(T)
23000 UUOEX1: LDB T,[POINT 5,JOBUUO,ACFLD]
23050 TRZN T,20
23100 PUSH P,UUOH
23150 PUSH P,TT
23200 JUMPE T,IAPPLY
23250 CAIN T,17
23300 MOVEI T,1
23350 MOVNS T
23400 HRLZ TT,T
23450 PUSH P,A(TT)
23500 AOBJN TT,.-1
23550 JRST IAPPLY
23600 PAGE
23650 ARGPDL: LDB T,[POINT 4,JOBUUO,ACFLD]
23700 MOVNS T
23750 HRLZ R,T
23800 ARGP1: JUMPE R,(TT)
23850 PUSH P,A(R)
23900 AOBJN R,.-1
23950 JRST (TT)
24000
24050 QTIFY: PUSHJ P,NCONS
24100 MOVEI B,CQUOTE(S)
24150 JRST XCONS
24200
24250 QTLFY: MOVEI A,0
24300 QTLFY1: JUMPE T,(TT)
24350 EXCH A,(P)
24400 PUSHJ P,QTIFY
24450 POP P,B
24500 PUSHJ P,CONS
24550 AOJA T,QTLFY1
24600
24650 PDLARG: JRST .+NACS+2(T)
24700 POP P,A+5
24750 POP P,A+4
24800 POP P,A+3
24850 POP P,A+2
24900 POP P,A+1
24950 POP P,A
25000 JRST (TT)
25050
25100 NOUUO: MOVSI B,(TLNN TT,)
25150 SKIPE A
25200 MOVSI B,(TLNA)
25250 HLLM B,UUOCL
25300 EXCH A,NOUUOF#
25350 POPJ P,
25400 PAGE
25450 ;r=0 => compiler calling a -
25500 ;r=1 => compiler calling a lsubr
25550 ;r=2 => compiler calling f type
25600 UUST: UUOSBR
25650 UUOS1 ;calling l its a subr
25700 UUOS2 ;calling f
25750
25800
25850 UUFST: UUOS9 ;calling - its a f
25900 UUOS10 ;calling l
25950 UUOSBR
26000
26050 UULT: UUOS7 ;calling - its a l
26100 UUOSBR
26150 UUOS8
26200
26250 UUET: UUOEXP
26300 UUOS5 ;calling l its an expr
26350 UUOS6 ;calling f its an expr
26400
26450 UUFET: UUOS3 ;calling - its a fexpr
26500 UUOS4 ;calling l
26550 UUOEXP
26600
26650 UUOS1: HLRZ R,(T)
26700 MOVE T,TSV
26750 JSP TT,PDLARG
26800 JRST (R)
26850
26900 UUOS3: PUSH P,(T)
26950 JSP TT,ARGPDL
27000 UUOS4A: JSP TT,QTLFY
27050 MOVEI TT,1
27100 DPB TT,[POINT 4,JOBUUO,ACFLD]
27150 UUOS6A: POP P,TT
27200 HLRZS TT
27250 JRST UUOEX1
27300
27350 UUOS4: PUSH P,(T)
27400 MOVE T,TSV
27450 JRST UUOS4A
27500 PAGE
27550 UUOS5: HLRZ R,(T)
27600 MOVE T,TSV
27650 JSP TT,PDLARG
27700 MOVE TT,R
27750 JRST UUOEX1
27800
27850 UUOS6: PUSH P,(T)
27900 PUSH P,UUOH
27950 PUSH P,JOBUUO
28000 JSP TT,ILIST
28050 JSP TT,PDLARG
28100 POP P,JOBUUO
28150 POP P,UUOH
28200 JRST UUOS6A
28250 UUOS8: SKIPA TT,CILIST
28300 UUOS7: MOVEI TT,ARGPDL
28350 HRRM TT,UUOS7A
28400 MOVE TT,JOBUUO
28450 TLNN TT,1000
28500 PUSH P,UUOH
28550 HLRZ TT,(T)
28600 JRST @UUOS7A ;OR ILIST
28650 REMOTE<UUOS7A: ARGPDL>
28700
28750 UUOS9: PUSH P,T
28800 JSP TT,ARGPDL
28850 UUS10A: JSP TT,QTLFY
28900 MOVSI T,2000
28950 IORM T,JOBUUO
29000 POP P,T
29050 JRST UUOSBR
29100
29150 UUOS10: PUSH P,T
29200 MOVE T,TSV
29250 JRST UUS10A
29300
29350 SUBTTL ERROR HANDLER AND BACKTRACE --- PAGE 5
29400 ;subroutine to print sixbit error message
29450 ERRSUB: MOVSI A,(POINT 6,0)
29500 HRR A,JOBUUO
29550 MOVEM A,ERRPTR#
29600 ERRORB: ILDB A,ERRPTR
29650 CAIN A,01 ;conversion from sixbit
29700 POPJ P,
29750 CAIN A,77
29800 JRST [ PUSHJ P,TERPRI
29850 JRST ERRORB]
29900 ADDI A,40
29950 PUSHJ P,TYO
30000 JRST ERRORB
30050
30100 ;subroutine to return output to previously selected device
30150 OUTRET: SKIPL PRVCNT ;if prvcnt<0 then there was no device deselect
30200 SOSL PRVCNT ;when prvcnt goes negative, then reselect
30250 POPJ P,
30300 PUSH P,PRVSEL# ;previously selected output
30350 POP P,TYOD
30400 POPJ P,
30450
30500 ;subroutine to force error messages out on tty
30550 ERRIO: MOVE B,ERRSW
30600 CAIE B,INUM0 ;inum0 specifies to print message on selected device
30650 AOSLE PRVCNT ;only if prvcnt already <0 does deselection occur
30700 POPJ P,
30750 TALK ;undo control o
30800 MOVE B,[JRST TTYO]
30850 EXCH B,TYOD
30900 MOVEM B,PRVSEL
30950 POPJ P,
31000
31050 ;ERRTN: 0 ;0 => top level *
31100 ;- => pdl to reset to - stored by errorset
31150 ;+ => string tyo pout rtn flag
31200 REMOTE<ERRSW: -1> ;0 means no prnt on error *
31250 PAGE
31300 ;subroutine to search oblist for closest function to address in r
31350 ERSUB3:
31400 MOVEI A,QST(S)
31450 HRROI NIL,CNIL2(S)
31500 HRLZ B,INT1
31550 MOVNS B
31600 SETZB AR2A,GOBF
31650 PUSH P,JOBAPR
31700 MOVEI C,[ SETOM GOBF
31750 JRST ERRO2G]
31800 HRRM C,JOBAPR
31850 HLRZ C,@RHX5
31900 ERRO2B: JUMPE C,[ AOBJN B,.-1
31950 POP P,JOBAPR ;oblist done, restore
32000 JRST PRINC] ;print closest match
32050 HLRZ TT,(C)
32100 ERRO2C: HRRZ TT,(TT)
32150 JUMPE TT,ERRO2G
32200 HLRZ AR1,(TT)
32250 CAIN AR1,LSUBR(S)
32300 JRST ERRO2H
32350 CAIE AR1,SUBR(S)
32400 CAIN AR1,FSUBR(S)
32450 JRST ERRO2H
32500 HRRZ TT,(TT)
32550 JRST ERRO2C
32600
32650 ERRO2H: HRRZ TT,(TT)
32700 HLRZ TT,(TT)
32750 CAMLE TT,AR2A ;le to prefer car to quote
32800 CAMLE TT,R
32850 JRST ERRO2G
32900 MOVE AR2A,TT
32950 HLRZ A,(C)
33000 ERRO2G: HRRZ C,(C)
33050 JRST ERRO2B
33100 PAGE
33150 ;dispatcher for error message uuos
33200 ERROR: MOVEI A,APRFLG
33250 CALLI A,APRINI ;enable interupts
33300 LDB A,[POINT 9,JOBUUO,OPFLD] ;get opcode
33350 CAIL A,UUOMIN ;what
33400 CAILE A,UUOMAX ;is it?
33450 JRST ILLUUO ;an illegal opcode
33500 JRST @ERRTAB-UUOMIN(A) ;or LISP error
33550 ERRTAB: ERROR1 ;1 ;ordinary LISP error
33600 ERRORG ;2 ;space overflow error
33650 ERROR2 ;3 ;ill. mem. ref.
33700 STRTYP ;4 ;print error message and continue
33750 ERRORG: MOVE P,ERRTN ;IF IN ERRSET, RESTORE P TO THAT LEVEL
33800 SKIPN P
33850 MOVE P,C2 ;else to top level
33900 SETOM UUO2# ;$$ AND DON'T ENTER ERRORX
33950
34000 ERROR1: SKIPN ERRSW
34050 JRST ERREND ;dont print message, call (err nil)
34100 PUSHJ P,ERRIO ;print message on tty
34150 PUSHJ P,TERPRI
34200 PUSHJ P,ERRSUB ;print the message
34250 JRST ERRBK ;go the backtrace
34300
34350 STRTYP: PUSHJ P,ERRIO
34400 PUSHJ P,ERRSUB ;print message and continue
34450 PUSHJ P,OUTRET
34500 JRST @UUOH
34550
34600 ;USER ENTRY TO ERROR HANDLER, PRINTS ARG IF NON-NIL
34650 .ERROR: JUMPE A,ERREND
34700 SKIPN ERRSW
34750 JRST ERREND
34800 PUSHJ P,ERRIO
34850 PUSHJ P,TERPRI
34900 PUSHJ P,PRINC
34950 JRST ERREND
35000 PAGE
35050 ERROR2: HRRZ A,JOBUUO
35100 MOVEI B,[SIXBIT / ILL MEM REF FROM !/]
35150 JRST ERSUB2
35200
35250 ILLUUO: HRRZ A,UUOH
35300 MOVEI B,[SIXBIT / ILL UUO FROM !/]
35350 ERSUB2: SKIPN ERRSW
35400 JRST ERREND ;dont print message
35450 PUSH P,A
35500 PUSH P,B
35550 PUSHJ P,ERRIO
35600 PUSHJ P,TERPRI
35650 PUSHJ P,PRINL2 ;print number
35700 POP P,A
35750 STRTIP (A) ;print message
35800 POP P,R
35850 PUSHJ P,ERSUB3 ;print nearest oblist match
35900 ERRBK:
35950 IFN ALVINE,<
36000 SKIPE BACTRF
36050 PUSHJ P,BKTRC ;print backtrace
36100 >
36150 PUSHJ P,OUTRET ;return to previous device
36200 ERREND: PUSHJ P,%CLRBFI ;CLEAR INPUT BUFFER
36250 SKIPN UUO2 ;$$NO ERRORX IF OVERFLOW ERROR
36300 JRST .+3
36350 SETZM UUO2 ;$$RESET TO ZERO
36400 JRST RERX ;$$BOUNCE BACK TO ERRORX
36450 SKIPN RSTSW ;$$NEW *RSET FEATURE
36500 JRST ERR ;$$IF (*RSET NIL) UNBIND AND GO TO TOP LEVEL
36550 SKIPN ERRSW ;$$NO ERRORX IF NO MESSAGE
36600 JRST ERR ;$$
36650 MOVEI A,ERRORX(S) ;$$ELSE SET TO CALL ERROR HANDLER
36700 MOVEI B,NIL ;$$CREATE FORM (ERRORX)
36750 CEV: PUSHJ P,CONS ;$$
36800 JRST EVAL ;$$AND EVALUATE IT
36850
36900
36950 ERR: SETZM INHERR ;CLEAR RERX FLAG JUST IN CASE
37000 CAIN A,ERRORX(S) ;$$BOUNCE TO ERRORX IF A=ERRORX
37050 JRST RERX
37100 ERR2: SKIPN ERRTN
37150 JRST LSPRET ;not in an errset, or bad error -- go to top level
37200 MOVE P,ERRTN
37250 ERR1: POP P,B
37300 PUSHJ P,UBD ;unbind to previous errset
37350 POP P,ERRSW
37400 POP P,ERRTN
37450 SKIPN INHERR#
37500 JRST ERRP4 ;and proceed
37550
37600 RERX: SETZM INHERR ;$$ POP TO A BREAK ERRSET
37650 MOVE B,ERRSW
37700 CAIE B,ERRORX(S)
37750 SETOM INHERR
37800 JRST ERR2
37850
37900 ERRSET: PUSH P,PA3
37950 PUSH P,PA4
38000 PUSH P,ERRTN
38050 PUSH P,ERRSW
38100 PUSH P,SP
38150 MOVEM P,ERRTN
38200 HRRZ C,(A)
38250 HLRZ C,(C)
38300 MOVEM C,ERRSW
38350 HLRZ A,(A)
38400 PUSHJ P,EVAL
38450 PUSHJ P,NCONS
38500 SETZM INHERR ;CLEAR RERX FLAG
38550 JRST ERR1
38600
38650 SYSCLR: SETZM BSFLG ;FUNCTION TO MAKE SYSTEM LOOK NEW
38700 JRST FALSE ;MIGHT BE EXTENDED LATER
38750 PAGE
38800 ;error messages
38850
38900
38950
39000
39050 RMERR: MOVE A,T ;$$ BAD READ MACRO, GET THE NAME
39100 PUSHJ P,EPRINT ;$$
39150 ERR1 [SIXBIT /UNDEFINED READ MACRO!/]
39200 BNDERR: PUSHJ P,EPRINT ;$$ATTEMPT TO REBIND NIL OR T
39250 ERR1 [SIXBIT /CANNOT BE RE-BOUND!/]
39300
39350 RPAERR: PUSHJ P,EPRINT ;$$PRINT OUT OFFENDING ITEM
39400 ERR1 [SIXBIT /IS AN ATOM, CAN'T BE RPLACA'D!/]
39450
39500 RPDERR: PUSHJ P,EPRINT ;$$
39550 ERR1 [SIXBIT /CAN'T BE RPLACD'D (NIL OR INUM)!/]
39600
39650 DOTERR: SETZM OLDCH
39700 ERR1 [ SIXBIT /DOT CONTEXT ERROR!/]
39750 UNDFUN: HLRZ A,(AR1)
39800 PUSHJ P,EPRINT
39850 ERR1 [SIXBIT /UNDEFINED FUNCTION!/]
39900 UNBVAR: PUSHJ P,EPRINT
39950 ERR1 [SIXBIT /UNBOUND VARIABLE - EVAL!/]
40000 NONNUM: ERR1 [SIXBIT /NON-NUMERIC ARGUMENT!/]
40050 NOPNAM: ERR1 [SIXBIT /NO PRINT NAME - INTERN!/]
40100 NOLIST: ERR1 [SIXBIT /NO LIST-MAKNAM!/]
40150 TOMANY: ERR1 [SIXBIT /TOO MANY ARGUMENTS SUPPLIED - APPLY!/]
40200 TOOFEW: ERR1 [SIXBIT /TOO FEW ARGUMENTS SUPPLIED - APPLY!/]
40250 UNDTAC: HRRZ A,(C)
40300 UNDTAG: PUSHJ P,EPRINT
40350 ERR1 [SIXBIT /UNDEFINED FUNCTION - APPLY!/]
40400 SETERR: PUSHJ P,EPRINT ;$$BAD SET OR SETQ
40450 ERR1 [SIXBIT /CAN'T BE SET TO A VALUE - SET OR SETQ!/]
40500 EG1: PUSHJ P,EPRINT
40550 ERR1 [SIXBIT /UNDEFINED PROG TAG-GO!/]
40600 EG2: PUSHJ P,EPRINT
40650 ERR1 [SIXBIT /GO WITH NO PROG!/]
40700 EG3: ERR1 [SIXBIT /RETURN WITH NO PROG!/]
40750 PAGE
40800 IFN ALVINE,<
40850
40900 ;backtrace subroutine
40950 BKTRC: MOVEI D,-1(P)
41000 MOVN A,BACTRF
41050 ADDI A,INUM0
41100 JUMPL A,[ ADD A,P ;backtrace specific number
41150 JRST .+3]
41200 SKIPN A,ERRTN ;backtrace to previous errset
41250 MOVE A,C2 ;or top level
41300 HRRZM A,BAKLEV#
41350 STRTIP [SIXBIT /←BACKTRACE←!/]
41400 BKTR2: CAMG D,BAKLEV
41450 JRST FALSE ;done
41500 HRRZ A,(D) ;get pdl element
41550 CAIGE A,FS(S)
41600 JUMPN A,.+2 ;this is (hopefully) a true program address
41650 SOJA D,BKTR2 ;not a program address, continue
41700 CAIN A,ILIST3
41750 JRST BKTR1A ;argument evaluation
41800 BKTR1B: CAIN A,CPOPJ
41850 JRST [ HLRZ A,(D) ;calling a function
41900 PUSHJ P,PRINC
41950 XCT "-",CTY
42000 STRTIP [SIXBIT /ENTER !/]
42050 SOJA D,BKTR2]
42100 HLRZ B,-1(A)
42150 CAILE B,(JCALLF 17,@(17))
42200 CAIN B,(PUSHJ P,) ;tests for various types of calls
42250 CAIGE B,(FCALL)
42300 SOJA D,BKTR2 ;not a proper function call
42350 PUSH P,-1(A) ;save object of function call
42400 MOVEI R,-1(A) ;location of function call
42450 PUSHJ P,ERSUB3 ;print closest oblist match
42500 MOVEI A,"-"
42550 PUSHJ P,TYO
42600 POP P,R
42650 TLNE R,17
42700 HRRZ R,ERSUB3 ;qst -- cant handle indexed calls
42750 HRRZS R
42800 HLRO B,(R)
42850 AOSN B
42900 JRST [ HRRZ A,R ;was calling an atomic function
42950 PUSHJ P,PRINC ;print its name
43000 JRST .+2]
43050 PUSHJ P,ERSUB3 ;was calling a code location -- print closest match
43100 MOVEI A," "
43150 PUSHJ P,TYO
43200 BKTR1: SOJA D,BKTR2 ;continue
43250
43300 BKTR1A: HRRZ B,-1(D)
43350 CAIE B,EXP2
43400 CAIN B,ESB1
43450 JRST .+2
43500 JRST BKTR1B ;hum, not really evaluating arguments
43550 HLRE B,-1(D)
43600 ADD B,D
43650 HLRZ A,-3(B)
43700 JUMPE A,BKTR1
43750 PUSHJ P,PRINC
43800 XCT "-",CTY
43850 STRTIP [SIXBIT /EVALARGS !/]
43900 JRST BKTR1
43950 >
44000
44050 BAKGAG: EXCH A,BACTRF#
44100 POPJ P,
00050 SUBTTL TYI AND TYO --- PAGE 6
00100 ;input
00150 ITYI: PUSHJ P,TYI
00200 FIXI: ADDI A,INUM0
00250 POPJ P,
00300
00350 TYI: MOVEI AR1,1
00400 PUSHJ P,TYIA
00450 JUMPE A,.-1
00500 CAME A,IGSTRT ;start of comment or ignored cr-lf
00550 POPJ P,
00600 PUSHJ P,COMMENT
00650 JRST TYI+1
00700
00750 TYIA: SKIPE A,OLDCH
00800 JRST TYI1
00850 TYID: XCT TYI2
00900 REMOTE<TYI2: JRST TTYI> ;sosg x for other device input
00950 ;other device input
01000 JRST TYI2X
01050 TYI3B: ILDB A,@TYI3# ;pointer
01100 XCT TYI3A
01150 REMOTE<TYI3A: TDNN AR1,@X> ;pointer
01200 POPJ P,
01250 IFN STPGAP,<
01300 MOVE A,@TYI3A
01350 CAMN A,[<ASCII / />+1] ;page mark for stopgap
01400 AOSA PGNUM ;increment page number
01450 MOVEM A,LINUM
01500 >
01550 MOVNI A,5
01600 ADDM A,@TYI2 ;adjust character count for line number
01650 AOS @TYI3 ;increment byte pointer over line number and tab
01700 JRST TYID
01750
01800 REMOTE< TYI2X: INPUT X,
01850 TYI2Y: STATZ X,740000
01900 ERR1 AIN.8 ;input error
01950 TYI2Z: STATO X,20000
02000 JRST TYI3B ;continue with file
02050 JRST TYI2Q ;END OF FILE>
02100 TYI2Q: PUSH P,T
02150 PUSH P,C
02200 PUSH P,R
02250 PUSH P,AR1
02300 MOVE A,INCH
02350 HRRZ C,CHTAB(A) ;get location of data for this channel
02400 HLRZ T,CHTAB(A) ;inlst -- remaining files to input
02450 JUMPE T,TYI2E ;none left -- stop
02500 PUSHJ P,SETIN ;start next input
02550 POP P,AR1
02600 POP P,R
02650 POP P,C
02700 POP P,T
02750 JRST TYI
02800
02850 TYI2E: PUSHJ P,INCNT ;(inc nil t)
02900 TALK ;turn off control o
02950 MOVEI A,$EOF$(S) ;we are done
03000 JRST ERR
03050
03100 IFN STPGAP,<
03150 PGLINE: MOVE C,[POINT 7,LINUM]
03200 PUSHJ P,NUM10 ;convert ascii line number to a integer
03250 ADDI A,INUM0
03300 MOVE B,PGNUM
03350 ADDI B,INUM0+1
03400 JRST XCONS>
03450
03500 REMOTE< OLDCH: 0
03550 IFN STPGAP,<
03600 PGNUM: 0
03650 LINUM: 0
03700 0>> ;zero to terminate num10
03750
03800 ;TTYECHO - COMPLEMENTS THE TTY: ECHO BIT AND RETURNS T IF THE ECHO
03850 ; IS BEING TURNED ON AND NIL IF IT IS BEING TURNED OFF
03900 ; - TAKES NO ARGUMENTS
03950 ECHO: SETO A,
04000 TTYUUO 6,A ;GET STATUS BITS
04050 TLC A,4 ;COMPLEMENT THE ECHO BIT
04100 TTYUUO 7,A ;RESTORE THE BITS
04150 TLNE A,4 ;TEST TO GET FINAL VALUE
04200 JRST FALSE
04250 JRST TRUE
04300
04350 ;CLRBFI - CLEARS TTY INPUT BUFFER FOR USER ERRORS
04400 ; - 0 ARGS AND RETURNS NIL
04450 %CLRBFI:CLRBFI ;CLEAR BUFFER
04500 SETZM SMAC ;CLEAR SPLICE LIST
04550 SETZM OLDCH ;CLEAR LAST CHAR.
04600 JRST FALSE
04650 PAGE
04700 ;teletype input
04750
04800 TTYI: SKIPE DDTIFG
04850 JRST TTYID
04900 INCHSL A ;single char if line has been typed
04950 JRST [TALK ;turn off control o, this
05000 ;can be omitted when ttyser is fixed
05050 OUTCHR PROMCH# ;$$OUTPUT PROMPT CHARACTER
05100 INCHWL A ;wait for a line
05150 JRST .+1]
05200 TTYXIT: CAIE A,BELL
05250 POPJ P,
05300 IFN ALVINE,<
05350 SKIPE PSAV1# ;bell from alvine?
05400 JRST [ MOVE P,PSAV1 ;yes, return to alvine
05450 JRST @ED1];$$DOUBLY IMPROVED MAGIC>
05500 MOVEI A,NIL ;$$ RETURN NIL AS THE VALUE
05550 JRST RERX ;$$ RETURN TO AN ERRORX ERRSET
05600
05650 TTYID: TALK ;turn off control o, remove this when ttyser works
05700 INCHRW A ;single character input ddt submode style
05750 CAIE A,RUBOUT
05800 JRST TTYXIT
05850 OUTCHR ["\"] ;echo backslash
05900 SKIPE PSAV
05950 JRST RDRUB ;rubout in read resets to top level of read
06000 MOVEI A,RUBOUT
06050 POPJ P,
06100
06150
06200 PROMPT: SKIPN A
06250 SKIPA A,PROMCH
06300 MOVEI A,-INUM0(A) ;$$CHANGE FROM INUM
06350 EXCH A,PROMCH# ;$$CHANGE PROMPT CHARACTER AND RETURN OLD ONE
06400 MOVEI A,INUM0(A) ;$$CHANGE TO INUM
06450 POPJ P, ;$$
06500
06550
06600 INTPRP: SKIPN A
06650 SKIPA A,LSPRMP
06700 EXCH A,LSPRMP# ;$$ EXCHANGE FOR OLD TOP LEVEL PROMPT
06750 POPJ P, ;$$
06800
06850 READP: SKPINC ;$$ T IFF A CHARACTER HAS BEEN TYPED
06900 JRST FALSE ;$$ (DOES NOT CHECK OLDCH)
06950 JRST TRUE
07000
07050 UNTYI: MOVEI B,-INUM0(A) ;$$ UN-READ A CHARACTER (PUT IT IN OLDCH)
07100 MOVEM B,OLDCH
07150 POPJ P, ;$$ RETURN ARG AS VALUE
07200 PAGE
07250 ;output
07300 ITYO: SUBI A,INUM0
07350 PUSHJ P,TYO
07400 JRST FIXI
07450
07500 TYO: CAIG A,CR
07550 JRST TYO3
07600 SOSGE CHCT
07650 JRST TYO1
07700 JRST TYOD
07750 REMOTE<TYOD: JRST TTYO+X ;sosg x for other device
07800 ;other device output
07850 JRST TYO2X
07900 TYO5: IDPB A,X
07950 POPJ P,
08000
08050 TYO2X: OUT X,
08100 JRST TYO5
08150 ERR1 [SIXBIT /OUTPUT ERROR!/]>
08200
08250 TYO1: PUSH P,A ;linelength exceeded
08300 MOVEI A,IGCRLF ;inored cr-lf
08350 PUSHJ P,TYOD
08400 PUSHJ P,TERPRI ;force out a cr-lf, with special mark
08450 POP P,A
08500 SOSA CHCT
08550 TYO4: POP P,B
08600 JRST TYOD
08650
08700 TYO3: CAIGE A,TAB
08750 JUMPN A,TYO+2 ;everything between 0(null) and 11(tab) decrement chct
08800 PUSH P,B
08850 MOVE B,LINL
08900 CAIN A,TAB
08950 JRST [ SUB B,CHCT
09000 IORI B,7 ;simulate tab effect on chct
09050 SUB B,LINL
09100 SETCAM B,CHCT
09150 JRST TYO4]
09200 CAIN A,CR
09250 MOVEM B,CHCT ;reset chct after a cr
09300 JRST TYO4
09350
09400 LINELENGTH:
09450 JUMPE A,LINEL1
09500 SUBI A,INUM0
09550 HRRM A,LINL
09600 HRRM A,CHCT
09650 LINEL1: HRRZ A,LINL
09700 JRST FIXI
09750
09800 CHRCT: MOVE A,CHCT
09850 JRST FIXI
09900
09950 REMOTE<
10000 LINL: TTYLL
10050 CHCT: TTYLL>
10100
10150 ;teletype output
10200 TTYO: OUTCHR A ;output single character in a
10250 POPJ P,
10300 PAGE
10350 REMOTE<DDTIFG: TRUTH>
10400 DDTIN: EXCH A,DDTIFG
10450 POPJ P,
10500
10550
10600 TTYRET: PUSHJ P,OUTCNT
10650 JRST INCNT
10700 ;THIS IS THE NEW, FAST, AND SHORT ROUTINE TO TURN OFF CONTROL O
10750 TTYCLR: SKPINC
10800 CAI
10850 POPJ P,
10900
10950 REMOTE<
11000 TTOCH: 0
11050 IFN STPGAP,<
11100 0 ;tty page number always zero
11150 0 ;tty line number -- always zero
11200 >
11250 TTOLL: TTYLL
11300 TTOHP: TTYLL>
11350 PAGE
11400 SUBTTL INPUT AND OUTPUT INITIALIZATION AND CONTROL --- PAGE 7
11450 ;convert ascii to sixbit for device initialization routines
11500 SIXMAK: SETZM SIXMK2#
11550 MOVE AR1,[POINT 6,SIXMK2]
11600 HRROI R,SIXMK1
11650 PUSHJ P,PRINTA ;use print to unpack ascii characters
11700 MOVE A,SIXMK2
11750 POPJ P,
11800
11850 SIXMK1: ADDI A,40
11900 TLNN AR1,770000
11950 POPJ P, ;last character position -- ignore remaining chars
12000 CAIN A,"."+40
12050 MOVEI A,0 ;ignore dots at end of numbers for decimal base
12100 CAIN A,":"+40
12150 HRLI AR1,(POINT 6,0,29) ;deposit : in last char position
12200 IDPB A,AR1
12250 POPJ P,
12300
12350 ;subroutine to process next item in file name list
12400 INXTIO: JUMPE T,NXTIO
12450 HRRZ T,(T)
12500 NXTIO: HLRZ A,(T)
12550 PUSHJ P,ATOM
12600 JUMPE A,CPOPJ ;non-atomic
12650 HLRZ A,(T)
12700 JRST SIXMAK ;make sixbit if atomic
12750
12800 ;right normalize sixbit
12850 LSH A,-6
12900 SIXRT: TRNN A,77
12950 JRST .-2
13000 POPJ P,
13050 PAGE
13100 IOSUB: PUSHJ P,NXTIO
13150 MOVEM T,DEVDAT#
13200 LDB B,[POINT 6,A,35]
13250 JUMPE A,IOPPN ;non-atomic item, must be ppn or (file.ext)
13300 CAIE B,":"-40
13350 JRST IOFIL ;not a device name -- must be file name
13400 TRZ A,77 ;clear out the :
13450 SETZM PPN
13500 IODEV2: MOVEM A,DEV
13550 PUSHJ P,INXTIO
13600 IOPPN: JUMPN A,IOFIL ;not ppn or (fil.ext)
13650 PUSHJ P,PPNEXT
13700 JUMPN A,IOEXT ;(fil.ext)
13750 HLRZ A,(T)
13800 HLRZ A,(A) ;caar is project number
13850 IFE STANSW,< HRRZI A,-INUM0(A) ;$$ASSUME PROJECT NUMBER IS AN INUM>
13900 IFN STANSW,< PUSHJ P,SIXMAK
13950 PUSHJ P,SIXRT>
14000 HRLM A,PPN ;project number
14050 HLRZ A,(T)
14100 PUSHJ P,CADR ;cadar is programmer number
14150 IFE STANSW,< HRRZI A,-INUM0(A) ;$$ASSUME PROGRAMMER NUMBER IS AN INUM>
14200 IFN STANSW,< PUSHJ P,SIXMAK
14250 PUSHJ P,SIXRT>
14300 HRRM A,PPN ;programmer number
14350 HRLZI A,(SIXBIT /DSK/) ;disk is assumed
14400 JRST IODEV2
14450
14500 IOFIL: SKIPN DEV
14550 JRST AIN.1 ;no device named
14600 JUMPN A,IOFIL2 ;was it an atom
14650 JUMPE T,CPOPJ ;no, was it nil (end)
14700 PUSHJ P,PPNEXT
14750 JUMPE A,CPOPJ ;see a ppn, no file named
14800 IOEXT: HLRZ A,(T) ;(file.ext)
14850 HRRZ A,(A) ;get cdr == extension
14900 PUSHJ P,SIXMAK
14950 HLLM A,EXT
15000 HLRZ A,(T)
15050 HLRZ A,(A) ;get car = file name
15100 PUSHJ P,SIXMAK
15150 FIL: PUSH P,A
15200 PUSHJ P,INXTIO
15250 JRST POPAJ
15300
15350 IOFIL2: CAIN B,":"-40
15400 POPJ P, ;saw a :,not file name
15450 SETZM EXT ;file name -- clear extension
15500 JRST FIL
15550
15600 PPNEXT: JUMPE T,CPOPJ ;end of file name list
15650 HLRZ A,(T)
15700 HRRZ A,(A) ;cdar
15750 JRST ATOM ;ppn iff (not(atom(cdar l)))
15800
15850 CHNSUB: MOVE T,A
15900 HLRZ A,(T)
15950 PUSHJ P,ATOM
16000 JUMPE A,TRUE ;non-atomic head of list -- no channel named
16050 HLRZ A,(T)
16100 PUSHJ P,SIXMAK
16150 ANDI A,77
16200 CAIN A,":"-40
16250 JRST TRUE ;device name, assume channel name t
16300 HLRZ A,(T) ;channel name -- return it
16350 HRRZ T,(T)
16400 POPJ P,
16450
16500 REMOTE<
16550 CHTAB=.-FSTCH
16600 BLOCK NIOCH>
16650
16700 ;channel data
16750 CHNAM==0 ;name of channel
16800 CHDEV==1 ;name of device
16850 CHPPN==2 ;ppn for input channel
16900 CHOCH==3 ;oldch for input channels
16950 IFN STPGAP,<
17000 CHPAGE==4 ;page number for input
17050 CHLINE==5 ;line number for input
17100 CHDAT==6 ;device data
17150 POINTR==7 ;byte pointer for device buffer
17200 COUNT==10 ;character count for device buffer
17250 >
17300 IFE STPGAP,<
17350 CHDAT==4
17400 POINTR==5
17450 COUNT==6
17500 >
17550 CHLL==2 ;linelength for output channel
17600 CHHP==3 ;hposit for output channels
17650 PAGE
17700 ;search for channel name in chtab
17750 TABSR1: MOVE A,[XWD -NIOCH,FSTCH]
17800 MOVE C,CHTAB(A)
17850 CAME B,CHNAM(C)
17900 AOBJN A,.-2
17950 CAMN B,CHNAM(C)
18000 POPJ P, ;found it!!!
18050 JRST FALSE ;lost
18100
18150 ;search for channel name in chtab, and if not there find a free channel, and
18200 ;if no free channel, allocate a new buffer and channel
18250 TABSRC: MOVE B,A
18300 PUSHJ P,TABSR1
18350 JUMPN A,DEVCLR ;found the channel
18400 PUSH P,B
18450 MOVE B,0
18500 PUSHJ P,TABSR1 ;find a physical channel no. for a free channel
18550 JUMPE A,[ERR1 [SIXBIT $NO I/O CHANNELS LEFT !$]]
18600 POP P,B
18650 JUMPN C,DEVCLR ;found free channel which had buffer space previously
18700 PUSH P,A ;must allocate new buffer
18750 MOVEI A,BLKSIZ
18800 SETZ D, ;SPECIAL RELOCATION - SEE LOAD
18850 PUSHJ P,MORCOR ;expand core for buffer if necessary
18900 MOVE C,A
18950 POP P,A
19000 HRRM C,CHTAB(A)
19050 DEVCLR: HRRZ C,CHTAB(A)
19100 HRRZM B,CHNAM(C) ;store name
19150 HRRZM A,CHANNEL#
19200 POPJ P,
19250
19300 ;subroutine to reset all i/o channels -- used by excise and realloc
19350 IOBRST: HRRZ A,JOBREL
19400 HRLM A,JOBSA
19450 MOVEM A,CORUSE#
19500 MOVEM A,JOBSYM
19550 SETZM CHTAB+FSTCH
19600 MOVE A,[XWD CHTAB+FSTCH,CHTAB+FSTCH+1]
19650 BLT A,CHTAB+NIOCH+FSTCH-1 ;clear channel table
19700 JRST (R)
19750 PAGE
19800 INPUT: PUSHJ P,CHNSUB ;determine channel name
19850 PUSH P,A
19900 PUSHJ P,TABSRC ;get physical channel number
19950 PUSHJ P,SETIN ;init device
20000 JRST POPAJ
20050
20100 SETIN: MOVEM A,CHANNEL
20150 MOVE A,CHDEV(C)
20200 MOVEM A,DEV
20250 MOVE A,CHPPN(C)
20300 MOVEM A,PPN
20350 PUSHJ P,IOSUB ;get device and file name
20400 MOVEM A,LOOKIN ;file name
20450 MOVE A,DEV
20500 CALLI A,DEVCHR
20550 TLNN A,INB
20600 JRST AIN.2 ;not input device
20650 TLNN A,AVLB
20700 JRST AIN.4 ;not available
20750 MOVE A,CHANNEL
20800 DPB A,[POINT 4,ININIT,ACFLD] ;set up channel numbers
20850 DPB A,[POINT 4,INLOOK,ACFLD]
20900 DPB A,[POINT 4,ININBF,ACFLD]
20950 HRRZ B,CHTAB(A)
21000 HRLM T,CHTAB(A) ;save remaining file name list
21050 MOVEI A,CHDAT(B)
21100 MOVEM A,DEV+1 ;pointer to bufdat
21150 JRST ININIT
21200 REMOTE<
21250 ININIT: INIT X,
21300 DEV: X
21350 X
21400 JRST AIN.7 ;cant init
21450 PUSH B,DEV
21500 PUSH B,PPN
21550 INLOOK: LOOKUP X,LOOKIN
21600 JRST AIN.7 ;cant find file
21650 JRST IRET1>
21700 IRET1: PUSH B,[0] ;oldch
21750 IFN STPGAP,<
21800 PUSH B,[0] ;line number
21850 PUSH B,[0] ;page number
21900 >
21950 ADDI B,4
22000 HRRM B,JOBFF
22050 JRST ININBF
22100 REMOTE<
22150 ININBF: INBUF X,NIOB
22200 JRST TRUE
22250
22300 ENTR:
22350 LOOKIN: BLOCK 4
22400 EXT=LOOKIN+1
22450 PPN=LOOKIN+3
22500 >
22550 PAGE
22600 OUTPUT: PUSHJ P,CHNSUB ;get channel name
22650 PUSH P,A
22700 TRO A,400000 ;set bit for output
22750 PUSHJ P,TABSRC ;get physical channel nuber
22800 PUSHJ P,IOSUB ;get device and file name
22850 MOVEM A,ENTR ;file name
22900 SETZM ENTR+2 ;zero creation date
22950 MOVE A,CHANNEL
23000 DPB A,[POINT 4,AOUT2,ACFLD] ;setup channel numbers
23050 DPB A,[POINT 4,OUTENT,ACFLD]
23100 DPB A,[POINT 4,OUTOBF,ACFLD]
23150 HRRZ B,CHTAB(A)
23200 MOVEI A,CHDAT(B)
23250 HRLM A,AOUT3+1
23300 MOVE A,DEV
23350 MOVEM A,AOUT3
23400 CALLI A,DEVCHR
23450 TLNN A,OUTB
23500 JRST AOUT.2 ;not output device
23550 TLNN A,AVLB
23600 JRST AOUT.4 ;not available
23650 JRST AOUT2
23700 REMOTE<
23750 AOUT2: INIT X,
23800 AOUT3: X
23850 X
23900 JRST AOUT.4 ;cant init
23950 PUSH B,DEV
24000 OUTENT: ENTER X,ENTR
24050 JRST OUTERR ;cant enter
24100 JRST ORET1>
24150 ORET1: PUSH B,[LPTLL] ;linelength
24200 PUSH B,[LPTLL] ;chrct
24250 IFE STPGAP,< ADDI B,4>
24300 IFN STPGAP,< ADDI B,6>
24350 HRRM B,JOBFF
24400 XCT OUTOBF
24450 REMOTE<
24500 OUTOBF: OUTBUF X,NIOB
24550 >
24600 JRST POPAJ
24650
24700 OUTERR: PUSHJ P,AIOP
24750 LDB A,[POINT 3,ENTR+1,35]
24800 CAIE A,2
24850 ERR1 [SIXBIT /DIRECTORY FULL !/]
24900 ERR1 [SIXBIT /FILE IS WRITE PROTECTED !/]
24950 PAGE
25000 IOSEL: MOVE C,-1(P)
25050 JUMPE C,CPOPJ ;tty
25100 JUMPE B,IOSELZ ;dont release
25150 DPB C,[POINT 4,RLS,ACFLD]
25200 XCT RLS
25250 REMOTE<
25300 RLS: RELEASE X, ;release channel
25350 >
25400 HRRZS CHTAB(C) ;release channel table entry
25450 MOVEM 0,@CHTAB(C) ;blast channel name
25500 SETZM -1(P)
25550 IOSELZ: HRRZ C,CHTAB(C)
25600 POPJ P,
25650 PAGE
25700 INCNT: MOVEI A,NIL ;(INC NIL T)
25750 MOVEI B,TRUTH(S)
25800
25850 INC: PUSH P,INCH#
25900 PUSHJ P,IOSEL
25950 JUMPN B,INC2 ;released channel
26000 SKIPN C
26050 MOVEI C,TTOCH-CHOCH ;tty deselect
26100 IFN STPGAP,<
26150 MOVEI B,CHOCH(C)
26200 HRLI B,OLDCH
26250 BLT B,CHLINE(C) ;save channel data
26300 >
26350 IFE STPGAP,<
26400 MOVE B,OLDCH
26450 MOVEM B,CHOCH(C)
26500 >
26550 JRST INC2+1
26600 INC2: SETZM INCH ;CLEAR CHANNEL NOW IN CASE OF BREAK
26650 JUMPE A,ITTYRE ;select tty
26700 MOVE B,A
26750 PUSHJ P,TABSR1 ;determine physical channel number
26800 JUMPE A,[ERR1 [SIXBIT/NO INPUT - INC!/]]
26850 HRRZM A,INCH
26900 DPB A,[POINT 4,TYI2X,ACFLD] ;set up channel numbers
26950 DPB A,[POINT 4,TYI2Y,ACFLD]
27000 DPB A,[POINT 4,TYI2Z,ACFLD]
27050 HRRZ A,CHTAB(A)
27100 MOVEI T,COUNT(A)
27150 HRLI T,(SOSG)
27200 MOVEI B,POINTR(A)
27250 HRRM B,TYI3 ;set up tyi parameters
27300 HRRM B,TYI3A
27350 INC3:
27400 IFN STPGAP,<
27450 MOVSI B,CHOCH(A)
27500 HRRI B,OLDCH
27550 BLT B,LINUM ;restore channel data
27600 >
27650 IFE STPGAP,<
27700 MOVE B,CHOCH(A)
27750 MOVEM B,OLDCH
27800 >
27850 MOVEM T,TYI2
27900 IOEND: POP P,A
27950 JUMPE A,CPOPJ
28000 MOVE A,CHTAB(A) ;get channel name
28050 HRRZ A,(A)
28100 TRZ A,400000 ;clear output bit
28150 POPJ P,
28200
28250 ITTYRE: SETZM INCH
28300 MOVE T,[JRST TTYI] ;reselect tty
28350 MOVEI A,TTOCH-CHOCH
28400 JRST INC3
28450 PAGE
28500 OUTCNT: MOVEI A,0 ;(outc nil t)
28550 MOVEI B,1
28600
28650 OUTC: PUSH P,OUTCH#
28700 PUSHJ P,IOSEL
28750 JUMPN B,OUTC2 ;closed this file
28800 SKIPN C
28850 MOVEI C,TTOLL-CHLL ;tty deselect
28900 MOVE B,CHCT
28950 MOVEM B,CHHP(C) ;save channel data
29000 MOVE B,LINL
29050 MOVEM B,CHLL(C)
29100 JRST OUTC2+1
29150 OUTC2: SETZM OUTCH ;CLEAR CHANNEL NOW IN CASE OF BREAK
29200 JUMPE A,OTTYRE ;return to tty
29250 TRO A,400000 ;set output bit
29300 MOVE B,A
29350 PUSHJ P,TABSR1 ;determine physical channel number
29400 JUMPE A,[ERR1 [SIXBIT /NO OUTPUT - OUTC!/]]
29450 DPB A,[POINT 4,TYO2X,ACFLD] ;set up tyo2 channel numbers
29500 HRRZM A,OUTCH
29550 HRRZ A,CHTAB(A)
29600 MOVEI B,POINTR(A)
29650 HRRM B,TYO5 ;set up tyo2 parameters
29700 MOVEI T,COUNT(A)
29750 HRLI T,(SOSG)
29800 OUTC3: MOVE B,CHLL(A)
29850 MOVEM B,LINL
29900 MOVE B,CHHP(A)
29950 MOVEM B,CHCT
30000 MOVEM T,TYOD
30050 JRST IOEND
30100
30150 OTTYRE: SETZM OUTCH
30200 MOVE T,[JRST TTYO]
30250 MOVEI A,TTOLL-CHLL ;tty reselect
30300 JRST OUTC3
30350 PAGE
30400 AIN.1: PUSHJ P,AIOP
30450 ERR1 [SIXBIT $ILLEGAL I/O ARG!$]
30500 AOUT.2:
30550 AIN.2: PUSHJ P,AIOP
30600 ERR1 [SIXBIT /ILLEGAL DEVICE!/]
30650 AOUT.4:
30700 AIN.4: PUSHJ P,AIOP
30750 ERR1 [SIXBIT /DEVICE NOT AVAILABLE !/]
30800 AIN.7: PUSHJ P,AIOP
30850 ERR1 [SIXBIT /CAN'T FIND FILE - INPUT!/]
30900
30950 AIN.8: SIXBIT /INPUT ERROR!/
31000
31050 AIOP: MOVE A,DEVDAT
31100 JRST EPRINT
00050 SUBTTL PRINT --- PAGE 8
00100
00150 EPRINT: SKIPN ERRSW
00200 POPJ P,
00250 PUSHJ P,ERRIO
00300 PUSHJ P,PRINT
00350 JRST OUTRET
00400
00450 PRINT: MOVEI R,TYO
00500 PUSHJ P,TERPRI
00550 PUSHJ P,PRIN1
00600 XCT " ",CTY
00650 POPJ P,
00700
00750 PRINC: SKIPA R,.+1
00800 PRIN1: HRRZI R,TYO
00850 PUSH P,A
00900 PUSHJ P,PRINTA
00950 JRST POPAJ
01000
01050 PRINTA: PUSH P,A
01100 MOVEI B,PRIN3
01150 SKIPGE R
01200 MOVEI B,PRIN4
01250 HRRM B,PRIN5
01300 PUSHJ P,PATOM
01350 JUMPN A,PRINT1
01400 XCT "(",CTY
01450 PRINT3: HLRZ A,@(P)
01500 PUSHJ P,PRINTA
01550 HRRZ A,@(P)
01600 JUMPE A,PRINT2
01650 MOVEM A,(P)
01700 XCT " ",CTY
01750 PUSHJ P,PATOM
01800 JUMPE A,PRINT3
01850 XCT ".",CTY
01900 XCT " ",CTY
01950 PUSHJ P,PRIN1A
02000 PRINT2: XCT ")",CTY
02050 JRST POPAJ
02100
02150 PRINT1: PUSHJ P,PRIN1A
02200 JRST POPAJ
02250 PAGE
02300 PRIN1A: MOVE A,-1(P)
02350 CAILE A,INUMIN
02400 JRST PRINIC
02450 JUMPE A,PRIN1B
02500 CAIGE A,@GCP1
02550 CAIGE A,@GCPP1
02600 JRST PRINL
02650 PRIN1B: HRRZ A,(A)
02700 JUMPE A,PRINL
02750 HLRZ B,(A)
02800 HRRZ A,(A)
02850 CAIN B,PNAME(S)
02900 JRST PRINN
02950 CAIN B,FIXNUM(S)
03000 JRST PRINI1
03050 CAIN B,FLONUM(S)
03100 JRSTF @[XWD 0,PRINO] ; TURN OFF DIVIDE CHECK AND UNDERFLOW
03150 BPR: JRST PRIN1B ;bignums change here to JRST BPRINT
03200 JRST PRIN1B
03250
03300 PRINL2: MOVEI R,TYO
03350 JRST PRINL1
03400
03450 PRINL: XCT "#",CTY
03500 HRRZ A,-1(P)
03550 PRINL1: MOVEI C,8
03600 JRST PRINI3
03650
03700 PRINI1: SKIPA A,(A)
03750 PRINIC: SUBI A,INUM0
03800 HRRZ C,VBASE(S)
03850 SUBI C,INUM0
03900 JUMPGE A,PRINI2
03950 XCT "-",CTY
04000 MOVNS A
04050 PRINI2: MOVEI B,"."-"0"
04100 HRLM B,(P)
04150 CAIN C,TEN
04200 SKIPE %NOPOINT(S)
04250 JRST .+2
04300 PUSH P,PRINI4
04350 PRINI3: JUMPL A,[ MOVEI B,0 ;case of -2↑35
04400 MOVEI A,1
04450 DIVI A,(C)
04500 JRST .+2]
04550 IDIVI A,0(C)
04600 HRLM B,(P)
04650 SKIPE A
04700 PUSHJ P,.-3
04750 PRINI4: JRST FP7A1
04800
04850 PRINN: HLRZ A,(A)
04900 MOVEI C,2(SP)
04950 PUSHJ P,PNAMU3
05000 PUSH C,[0]
05050 HRLI C,(POINT 7,0,35)
05100 HRRI C,2(SP)
05150 ILDB A,C
05200 JUMPE A,CPOPJ ;special case of null character
05250 CAIN A,DBLQT
05300 JRST PSTR ;string
05350 PRIN2X: LDB B,[POINT 1,CHRTAB(A),1]
05400 JUMPL R,PRIN4 ;never slash
05450 JRST PRIN2(B) ;1 for no slash
05500
05550 PRIN3: SKIPL CHRTAB(A) ;<0 for no slash
05600 PRIN2: XCT "/",CTY
05650 PRIN4: PUSHJ P,(R)
05700 ILDB A,C
05750 JUMPN A,@PRIN5#
05800 POPJ P,
05850
05900 PSTR: MOVS B,(C)
05950 CAIN B,(<ASCII /"/>)
06000 JRST PRIN2X ;special case of /"
06050 PSTR3: SKIPL R ;dont print " if no slashify
06100 PSTR2: PUSHJ P,(R)
06150 ILDB A,C
06200 CAIE A,DBLQT
06250 JUMPN A,PSTR2
06300 JUMPN A,PSTR3
06350 POPJ P,
06400
06450 TERPRI: PUSH P,A
06500 MOVEI A,CR
06550 PUSHJ P,TYO
06600 MOVEI A,LF
06650 PUSHJ P,TYO
06700 JRST POPAJ
06750
06800 CTY: JSA A,TYOI
06850 REMOTE<
06900 TYOI: X
06950 JRST TYOI2>
07000 TYOI2: PUSH P,A
07050 LDB A,[POINT 6,-1(A),ACFLD]
07100 PUSHJ P,(R)
07150 POP P,A
07200 JRA A,(A)
07250
07300 PRINO: MOVE A,(A)
07350 CLEARB B,C
07400 JUMPG A,FP1
07450 JUMPE A,FP3
07500 MOVNS A
07550 XCT "-",CTY
07600 FP1: CAMGE A,FT01
07650 JRST FP4
07700 CAML A,FT8
07750 AOJA B,FP4
07800
07850 FP3: MULI A,400
07900 ASHC B,-243(A)
07950 MOVE A,B
08000 CLEARM FPTEM#
08050 PUSHJ P,FP7
08100 XCT ".",CTY
08150 MOVNI T,8
08200 ADD T,FPTEM
08250 MOVE B,C
08300
08350 FP3A: MOVE A,B
08400 MULI A,TEN
08450 PUSHJ P,FP7B
08500 SKIPE B
08550 AOJL T,FP3A
08600 POPJ P,
08650
08700 FP4: MOVNI C,6
08750 MOVEI TT,0
08800 FP4A: ADDI TT,1(TT)
08850 XCT FCP(B)
08900 TRZA TT,1
08950 FMPR A,@FCP+1(B)
09000 AOJN C,FP4A
09050 PUSH P,TT
09100 MOVNI B,-2(B)
09150 DPB B,[POINT 2,FP4C,34]
09200 PUSHJ P,FP3
09250 MOVEI A,"E"
09300 PUSHJ P,(R)
09350 MOVE A,FP4C#
09400 IORI A,51
09450 PUSHJ P,(R)
09500 POP P,A
09550 FP7: JUMPE A,FP7A1
09600 IDIVI A,TEN
09650 AOS FPTEM
09700 HRLM B,(P)
09750 JUMPE A,FP7A1
09800 PUSHJ P,FP7
09850
09900 FP7A1: HLRE A,(P)
09950 FP7B: ADDI A,"0"
10000 JRST (R)
10050
10100 353473426555 ;1e32
10150 266434157116 ;1e16
10200 FT8: 1.0E8
10250 1.0E4
10300 1.0E2
10350 1.0E1
10400 FT: 1.0E0
10450 026637304365 ;1e-32
10500 113715126246 ;1e-16
10550 146527461671 ;1e-8
10600 163643334273 ;1e-4
10650 172507534122 ;1e-2
10700 FT01: 175631463146 ;1e-1
10750 FT0:
10800 FCP: CAMLE A,FT0(C)
10850 CAMGE A,FT(C)
10900 XWD C,FT0
10950
00050 SUBTTL SUPER FAST TABLE DRIVEN READ 14-MAY-69 PAGE 9
00100
00150 ;magic scanner table bit definitions
00200
00250 ;bit 0=0 iff slashified as nth id character
00300 ;bit 1=0 iff slashified as 1st id character
00350 ;bits 2-5 ratab index
00400 ;bits 6-8 dotab index
00450 ;bits 9-10 strtab index
00500 ;bits 11-13 idtab index
00550 ;bits 14-16 exptab index
00600 ;bits 17-19 rdtab index
00650 ;bits 20-25 ascii to radix 50 conversion
00700
00750 REMOTE<
00800 IGSTRT: IGCRLF
00850 IGEND: LF
00900
00950 RATFLD: POINT 4,CHRTAB(A),5
01000 STRFLD: POINT 2,CHRTAB(A),10
01050 IDFLD: POINT 3,CHRTAB(A),13
01100 >
01150 DOTFLD:
01200 NUMFLD: POINT 3,CHRTAB(A),8
01250 EXPFLD: POINT 3,CHRTAB(A),16
01300 RDFLD: POINT 3,CHRTAB(A),19
01350 R50FLD: POINT 6,CHRTAB(A),25
01400
01450 ;magic state flags in t
01500 EXP==1 ;exponent
01550 NEXP==2 ;negative exponent
01600 SAWDOT==4 ;saw a dot (.)
01650 MINSGN==10 ;negative number
01700
01750 IDCLS==0 ;identifier
01800 STRCLS==1 ;string
01850 NUMCLS==2 ;number
01900 DELCLS==3 ;delimiter
01950
02000 PAGE
02050 ;macros for scanner table
02100
02150 DEFINE RAD50 (X)<
02200 IFB <X>,<R50VAL=0>
02250 IFLE <"X"-"9">,<IFGE <"X"-"0">,<R50VAL="X"-"0"+1>>
02300 IFIDN <"X"><".">,<R50VAL=45>
02350 IFGE <"X"-"A">,<R50VAL="X"-"A"+13>>
02400
02450 DEFINE TABIN (S1,SN,R,D,S,I,E,RD,R50)<
02500 XLIST
02550 IRPC R50< RAD50 (R50)
02600 BYTE (1)S1,SN(4)R(3)D(2)S(3)I,E,RD(6)R50VAL>
02650 LIST>
02700
02750 DEFINE LET (X)<
02800 TABIN (1,1,5,2,3,4,2,0,X)>
02850
02900 DEFINE DELIMIT (X,Y)<
02950 TABIN (0,0,2,2,3,2,2,Y,X)>
03000
03050 DEFINE IGNORE (X)<
03100 TABIN (0,0,3,2,3,2,2,0,X)>
03150 PAGE
03200 REMOTE<CHRTAB:
03250 TABIN (0,0,1,1,1,1,1,0,< >)
03300 ;null
03350 LET (< >)
03400 IGNORE (< >)
03450 ;tab,lf,vtab,ff,cr
03500 LET (< >)
03550 ;16 to 30
03600 TABIN (0,0,0,0,0,0,0,0,< >)
03650 ;igmrk
03700 TABIN (0,0,0,0,0,0,0,0,< >)
03750 ;32 THE OLD IGMRK, WILL ALLOW THE CHAR. TO WORK ON READS BUT NOT TYI
03800 LET (< >)
03850 ;33 to 37
03900 IGNORE (< >)
03950 ;space
04000 LET (< >)
04050 ;!
04100 TABIN (0,0,9,2,2,2,2,0,< >)
04150 ;"
04200 LET (< $% >)
04250 ;#$%&'
04300 DELIMIT (< >,0)
04350 DELIMIT (< >,1)
04400 ;()
04450 LET (< >)
04500 ;*
04550 TABIN (1,1,14,2,3,4,2,0,< >)
04600 ;+
04650 IGNORE (< >)
04700 ;,
04750 TABIN (1,1,6,2,3,4,2,0,< >)
04800 ;-
04850 TABIN (0,0,7,3,3,2,2,4,<.>)
04900 TABIN (0,0,4,2,3,3,2,0,< >)
04950 ;/
05000 TABIN (1,0,8,5,3,4,3,0,<0123456789>)
05050 LET (< >)
05100 ;:;<=>?
05150 TABIN (1,0,2,2,3,4,2,5,< >)
05200 ;@
05250 LET (<ABCD>)
05300 TABIN (1,1,5,4,3,4,2,0,<E>)
05350 LET (<FGHIJKLMNOPQRSTUVWXYZ>)
05400 DELIMIT (< >,2)
05450 ;[
05500 LET (< >)
05550 ;\
05600 DELIMIT (< >,3)
05650 ;]
05700 LET (< >)
05750 ;↑←`
05800 LET (<ABCDEFGHIJKLMNOPQRSTUVWXYZ>)
05850 ;lower case
05900 LET (< >)
05950 ;{¬
06000 DELIMIT (< >,3)
06050 ;altmode
06100 LET (< >)
06150 ;}
06200 DELIMIT (< >,6)
06250 ;rubout
06300 >
06350 PAGE
06400 READCH: PUSHJ P,TYI
06450 MOVSI AR1,AR1
06500 PUSHJ P,EXPL1
06550 JRST CAR
06600
06650 READP1: SETZM NOINFG
06700 READ0: PUSH P,TYI2
06750 PUSH P,OLDCH
06800 SETZM OLDCH#
06850 HRLI A,(JRST)
06900 MOVEM A,TYI2
06950 PUSHJ P,READ+1
07000 POP P,OLDCH
07050 POP P,TYI2
07100 POPJ P,
07150
07200 RDRUB: MOVEI A,CR
07250 PUSHJ P,TTYO
07300 MOVEI A,LF
07350 PUSHJ P,TTYO
07400 SKIPA P,PSAV#
07450 READ: SETZM NOINFG# ;0 means intern
07500 MOVEM P,PSAV
07550 PUSHJ P,READ1
07600 SETZM PSAV
07650 POPJ P,
07700
07750 READ1: PUSHJ P,RATOM
07800 POPJ P, ;atom
07850 XCT RDTAB2(B)
07900 JRST READ1 ;try again
07950
08000 RDTAB2: JRST READ2 ;0 (
08050 JFCL ;1 )
08100 JRST READ4 ;2 [
08150 JFCL ;3 ],$
08200 JFCL ;4 .
08250 JRST RDQT ;5 @
08300
08350 READ2: PUSHJ P,RATOM
08400 JRST READ2A ;atom
08450 XCT RDTAB(B)
08500
08550 READ2A: PUSH P,A
08600 PUSHJ P,READ2
08650 POP P,B
08700 JRST XCONS
08750
08800 RDTAB: PUSHJ P,READ2 ;0 (
08850 JRST FALSE ;1 )
08900 PUSHJ P,READ4 ;2 [
08950 JRST READ5 ;3 ],$
09000 JRST RDT ;4 .
09050 PUSHJ P,RDQT ;5 @
09100
09150 RDTX: PUSHJ P,RATOM
09200 POPJ P, ;atom
09250 XCT RDTAB2(B)
09300 JRST DOTERR ;dot context error
09350
09400 RDT: PUSHJ P,RDTX
09450 PUSH P,A
09500 PUSHJ P,RATOM
09550 JRST DOTERR
09600 CAIN B,1
09650 JRST POPAJ
09700 CAIE B,3
09750 JRST DOTERR
09800 MOVEM A,OLDCH
09850 JRST POPAJ
09900
09950
10000 READ4: PUSHJ P,READ2
10050 MOVE B,OLDCH
10100 CAIE B,ALTMOD
10150 TYI1: SETZM OLDCH ;kill the ]
10200 POPJ P,
10250
10300 READ5: MOVEM A,OLDCH ;save ] or $
10350 JRST FALSE ;and return nil
10400
10450
10500 RDQT: PUSHJ P,READ1
10550 JRST QTIFY
10600 PAGE
10650 ;atom parser
10700
10750 COMMENT: PUSHJ P,TYID
10800 CAME A,IGEND
10850 JRST COMMENT
10900 POPJ P,
10950
11000 RATOM: SKIPE SMAC# ;$$ CHECK FOR A SPLICE MACRO LIST
11050 JRST PSMAC ;$$ GET ITEM FROM SPLICE MACRO LIST
11100 SETZB T,R
11150 HRLI C,(POINT 7,0,35)
11200 HRRI C,(SP)
11250 MOVEM C,ORGSTK# ;SAVE FOR BACKING UP ON + AND -
11300 MOVEI AR1,1
11350 RATOM2: PUSHJ P,TYIA
11400 LDB B,RATFLD
11450 JRST RATAB(B)
11500
11550 RATAB: PUSHJ P,COMMENT ;0 comment
11600 JRST RATOM2 ;1 null
11650 JRST RATOM3 ;2 delimit
11700 JRST RATOM2 ;3 ignore
11750 PUSHJ P,TYI ;4 /
11800 JRST RDID ;5 letter
11850 JRST RDNMIN ;6 -
11900 JRST RDOT ;7 .
11950 JRST RDNUM ;8 digit
12000 JRST RDSTR ;9 string
12050 JRST RMACRO ;10 MACRO
12100 JRST SMACRO ;11 SPLICE MACRO
12150 JRST RDNPLS ;12 +
12200
12250 ;a real dotted pair
12300 RDOT2: MOVEM A,OLDCH
12350 MOVE A,ORGSGN ;ORGSGN NORMALLY CONTAINS A "." AT THIS POINT
12400 RATOM3: LDB B,RDFLD
12450 HRRI R,DELCLS ;delimiter
12500 AOS (P) ;non-atom (ie a delimiter)
12550 POPJ P,
12600
12650 ;dot handler
12700 RDOT: MOVEM A,ORGSGN ;INCASE SOMETHING ELSE DEFINED AS "."
12750 PUSHJ P,TYID
12800 LDB B,DOTFLD
12850 JRST DOTAB(B)
12900
12950 DOTAB: PUSHJ P,COMMENT ;0 comment
13000 JRST RDOT+1 ;1 null
13050 JRST RDOT2 ;2 delimit
13100 JRST RDOT2 ;3 dot
13150 JRST RDOT2 ;4 e
13200 MOVEI B,0 ;5 digit
13250 IDPB B,C
13300 TLO T,SAWDOT
13350 JRST RDNUM
13400 PAGE
13450 ;string scanner
13500 STRTAB: PUSHJ P,COMMENT ;0 comment
13550 JRST RDSTR+1 ;1 null
13600 JRST STR2 ;2 delimit
13650 RDSTR: IDPB A,C ;3 string element
13700 PUSHJ P,TYID
13750 LDB B,STRFLD
13800 JRST STRTAB(B)
13850
13900 STR2: MOVEI A,DBLQT
13950 HRRI R,STRCLS ;string
14000 IDPB A,C
14050 NOINTR: PUSHJ P,IDEND ;no intern
14100 PUSHJ P,IDSUB
14150 JRST PNAMAK
14200
14250
14300 ;identifier scanner
14350 IDTAB: PUSHJ P,COMMENT ;0
14400 JRST RDID+1 ;1 null
14450 JRST MAKID ;2 delimit
14500 PUSHJ P,TYI ;3 /
14550 RDID: IDPB A,C ;4 letter or digit
14600 PUSHJ P,TYID
14650 LDB B,IDFLD
14700 JRST IDTAB(B)
14750 PAGE
14800 ;LINEREAD - RETURNS ALL THE EXPRESSIONS ON ONE LINE AS A LIST
14850 ;
14900 LINRD: PUSHJ P,READ
14950 HRRZ B,A
15000 SKIPE SMAC ;CHECK THE SPLICE LIST
15050 JRST LRMORE
15100 SKIPN A,OLDCH
15150 LRTY: PUSHJ P,TYID ;NEED A CHARACTER
15200 MOVEM A,OLDCH ;SAVE IT
15250 LDB C,RATFLD ;THIS KLUDGE IS TO AVOID MAKING ANOTHER TABLE ENTRY
15300 CAIN C,7 ;SPECIAL CHECK FOR "."
15350 JRST LRTY1 ;IGNORE IT
15400 CAILE C,3 ;ELIMINATE MOST POSSIBILITIES
15450 JRST LRMORE ;MORE ON THE LINE
15500 JUMPE C,LREND ;END LINE ON COMMENT - THINK ABOUT IT, ITS RIGHT
15550 LDB C,RDFLD
15600 JRST LR1(C)
15650 LR1: JRST LPIG ;0 MORE TO FIGURE OUT
15700 JRST LRTY1 ;1 IGNORE
15750 JRST LRMORE ;2 MORE ON THE LINE
15800 SUBI A,ALTMOD ;3 CHECK ALTMOD
15850 JUMPN A,LRTY1 ;4 IGNORE "]" AND "."
15900 JUMPN A,LRMORE ;5 MORE ON "@"
15950 JRST LREND
16000 LPIG: CAIN A,"(" ;THESE SPECIAL CHECK COULD SCREW UP READ MACROS
16050 JRST LRMORE
16100 CAIE A,TAB
16150 CAIL A,40 ;READ MORE IF SPACE, COMMA, OR TAB
16200 JRST [ HRLI B,-1 ;SET SPQCE FLAG AND TRY AGAIN
16250 JRST LRTY]
16300 CAIE A,CR ;ALWAYS IGNORE CR.S
16350 TLZE B,-1 ;EOL - IF SPACE FLAG THEN DO A PEEKC
16400 JRST LRTY
16450 LREND: HRRZ A,B ;FINALLY GOT THERE
16500 JRST NCONS
16550 LRMORE: HRLI B,0
16600 PUSH P,B ;MORE TO GO, PUSH
16650 PUSHJ P,LINRD ;AND CALL YOURSELF
16700 POP P,B
16750 JRST XCONS
16800 LRTY1: HRLI B,0 ;CLEAR SPACE FLAG
16850 JRST LRTY
16900
16950 PAGE
17000 ;NEW AND SUBER BITCHEN READ MACROS
17050 ;
17100 RMACRO:
17150 IFN ALVINE,<
17200 SKIPE PSAV1 ;$$ ARE WE IN ALVINE?
17250 JRST RATOM2 ;$$ YES, IGNORE>
17300 RMAC2: IDPB A,C ;$$ CONVERT THE CHAR. TO AN ATOM
17350 PUSHJ P,IDEND ;$$
17400 PUSHJ P,INTER0 ;$$
17450 MOVEM A,T ;$$ SAVE ATOM IN CASE OF ERROR
17500 MOVEI B,READMACRO(S) ;$$ GET THE FUNCTION NAME
17550 PUSHJ P,GET ;$$
17600 JUMPE A,RMERR ;$$ UNDEFINED READ MACRO
17650 PUSHJ P,NCONS ;$$ CONVERT TO A FORM
17700 PUSH P,PSAV ;$$
17750 PUSHJ P,EVAL ;$$ EVALUATE THE FORM
17800 POP P,PSAV ;$$
17850 POPJ P, ;$$ RETURN
17900
17950 ;SPECIAL PROCESSING OF SPLICE MACROS
18000 SMACRO:
18050 IFN ALVINE,<
18100 SKIPE PSAV1 ;$$ ARE WE IN ALVINE?
18150 JRST RATOM2 ;$$ YES, IGNORE>
18200 PUSHJ P,RMAC2 ;$$ EVALUATE THE MACRO
18250 MOVEM A,SMAC ;$$ SAVE THE SPLICE LIST
18300 JRST RATOM ;$$ START OVER
18350
18400 ;GET AN ITEM OFF OF THE SPLICE LIST
18450 PSMAC: MOVE A,SMAC ;$$
18500 PUSHJ P,ATOM ;$$ IS SPLICE LIST AN ATOM?
18550 JUMPN A,[ MOVE A,SMAC ;$$ YES, SIMULATE . <ATOM>
18600 PUSHJ P,NCONS ;$$
18650 MOVEM A,SMAC ;$$
18700 MOVEI B,4 ;$$
18750 JRST RATOM3+1] ;$$
18800 MOVE B,@SMAC ;$$
18850 HLRZ A,B ;$$ RETURN NEXT ITEM OF SPLICE LIST
18900 HRRZM B,SMAC ;$$ ADVANCE SPLICE LIST
18950 POPJ P, ;$$ RETURN
19000 PAGE
19050 ;number scanner
19100 NUMTAB: PUSHJ P,COMMENT ;0 comment
19150 JRST RDNUM+1 ;1 null
19200 JRST NUMAK ;2 delimit
19250 JRST RDNDOT ;3 dot
19300 JRST RDE ;4 e
19350 RDNUM: IDPB A,C ;5 digit
19400 PUSHJ P,TYID
19450 LDB B,NUMFLD
19500 JRST NUMTAB(B)
19550
19600 RDNDOT: TLOE T,SAWDOT
19650 JRST NUMAK ;two dots - delimit
19700 MOVEI A,0
19750 JRST RDNUM
19800
19850 RDNMIN: TLO T,MINSGN
19900 RDNPLS: MOVEM A,ORGSGN# ;SAVE SIGN IN CASE OF BACKUP
19950 JRST RDNUM+1
20000
20050 ;exponent scanner
20100 RDE: CAME C,ORGSTK ;FOR +E AND -E TYPE OF ATOMS
20150 JRST .+3
20200 MOVEM A,OLDCH
20250 JRST KLDG1
20300 TLO T,EXP
20350 MOVEI A,0
20400 IDPB A,C
20450 PUSHJ P,TYID
20500 CAIN A,"-"
20550 TLOA T,NEXP
20600 CAIN A,"+"
20650 JRST RDE2+1
20700 JRST RDE2+2
20750
20800 EXPTAB: PUSHJ P,COMMENT ;0
20850 JRST RDE2+1 ;1 null
20900 JRST NUMAK ;2 delimit
20950 RDE2: IDPB A,C ;3 digit
21000 PUSHJ P,TYID
21050 LDB B,EXPFLD
21100 JRST EXPTAB(B)
21150 PAGE
21200 ;semantic routines
21250 ;identifier interner and builder
21300
21350 IDEND: TDZA A,A
21400 IDEND1: IDPB A,C
21450 TLNE C,760000
21500 JRST IDEND1
21550 POPJ P,
21600
21650 MAKID: MOVEM A,OLDCH
21700 PUSHJ P,IDEND
21750 SKIPE NOINFG
21800 JRST NOINTR ;dont intern it
21850 INTER0: PUSHJ P,IDSUB
21900 PUSHJ P,INTER1 ;is it in oblist
21950 POPJ P, ;found
22000 PUSHJ P,PNAMAK ;not there
22050 MAKID2: MOVE C,CURBUC# ;
22100 HLRZ B,@RHX2
22150 PUSHJ P,CONS ;cons it into the oblist
22200 HRLM A,@RHX2
22250 JRST CAR
22300
22350 ;pname unmaker
22400 PNAMUK:
22450 MOVEI B,PNAME(S)
22500 PUSHJ P,GET
22550 JUMPE A,NOPNAM
22600 MOVE C,SP
22650 PNAMU3: HLRZ B,(A)
22700 PUSH C,(B)
22750 HRRZ A,(A)
22800 JUMPN A,PNAMU3
22850 POPJ P,
22900
22950 ;idsub constructs a iowd pointer for a print name
23000 IDSUB: HRRZS C
23050 CAML C,JRELO ;top of spec pdl
23100 JRST SPDLOV
23150 MOVNS C
23200 ADDI C,(SP)
23250 HRLI C,1(SP)
23300 MOVSM C,IDPTR#
23350 POPJ P,
23400
23450 PAGE ;identifier interner
23500 INTER1: MOVE B,1(SP) ;get first word of pname
23550 LSH B,-1 ;right justify it
23600 IDIV B,INT1 ;compute hash code
23650 REMOTE<
23700 INT1: BCKETS
23750 RHX2:
23800 XXX1: XWD B+1,OBTBL>
23850 HLRZ TT,@RHX2 ;get bucket
23900 MOVEM B+1,CURBUC ;save bucket number
23950 MOVE T,TT
24000 JRST MAKID1
24050
24100 MAKID3: MOVE TT,T ;save previous atom
24150 HRRZ T,(T) ;get next atom
24200 MAKID1: JUMPE T,CPOPJ1 ;not in oblist
24250 HLRZ A,(T) ;next id in oblist
24300 MAKID4: HRRZ A,(A)
24350 JUMPE A,NOPNAM ;no print name
24400 MOVE A,(A)
24450 HLRZ C,A
24500 CAIE C,PNAME(S)
24550 JRST MAKID4
24600 MOVE C,IDPTR ;found pname
24650 HLRZ A,(A)
24700 MAKID5: JUMPE A,MAKID3 ;not the one
24750 MOVS A,(A)
24800 MOVE B,(A)
24850 ANDCAM AR1,(C) ;clear low bit
24900 CAME B,(C)
24950 JRST MAKID3 ;not the one
25000 HLRZ A,A ;ok so far
25050 AOBJN C,MAKID5
25100 JUMPN A,MAKID3 ;not the one
25150 HLRZ A,(T) ;this is it
25200 HLRZ B,(TT)
25250 HRLM A,(TT)
25300 HRLM B,(T)
25350 POPJ P,
25400
25450 ;pname builder
25500 PNAMAK: MOVE T,IDPTR
25550 PUSHJ P,NCONS
25600 MOVE TT,A
25650 MOVE C,A
25700 PNAMB: MOVE A,(T)
25750 TRZ A,1 ;clear low bit!!!!!
25800 PUSHJ P,FWCONS
25850 PUSHJ P,NCONS
25900 HRRM A,(TT)
25950 MOVE TT,A
26000 AOBJN T,PNAMB
26050 MOVE A,C
26100 HRLZS (A)
26150 JRST PNGNK1+1
26200 PAGE
26250 ;number builder
26300 NUMAK: MOVEM A,OLDCH
26350 HRRI R,NUMCLS ;number
26400 CAME C,ORGSTK ;BIG KLUDGE FOR + AND -
26450 JRST .+5
26500 KLDG1: MOVE A,ORGSGN ;ENTER HERE TO BACK UP IN THE CASE OF +E OR -E
26550 IDPB A,C
26600 PUSHJ P,TYIA
26650 JRST RDID+2
26700 MOVEI A,0
26750 IDPB A,C
26800 IDPB A,C
26850 HRRZS C
26900 CAML C,JRELO ;top of spec pdl
26950 JRST SPDLOV
27000 MOVSI C,(POINT 7,0,35)
27050 HRRI C,(SP)
27100 TLNE T,SAWDOT+EXP
27150 JRST NUMAK2 ;decimal number or flt pt
27200 MOVE A,VIBASE(S) ;ibase integrer
27250 SUBI A,INUM0
27300 PUSHJ P,NUM
27350 NUMAK4:
27400 MOVEI B,FIXNUM(S)
27450 NUMAK6: TLNE T,MINSGN
27500 MOVNS A
27550 JRST MAKNUM
27600
27650 NUMAK2: PUSHJ P,NUM10
27700 MOVEM A,TT
27750 TLNN T,SAWDOT
27800 JRST [ PUSHJ P,FLOAT ;flt pt without fraction
27850 MOVE TT,A
27900 JRST NUMAK3]
27950 PUSHJ P,NUM10 ;fraction part
28000 EXCH A,TT
28050 TLNN T,EXP
28100 JUMPE AR2A,NUMAK4 ;no exponent and no fraction
28150 PUSHJ P,FLOAT
28200 EXCH A,TT
28250 PUSHJ P,FLOAT
28300 MOVEI AR1,FT01
28350 PUSHJ P,FLOSUB
28400 FMPR A,B
28450 FADRM A,TT
28500 NUMAK3: PUSHJ P,NUM10 ;exponent part
28550 MOVE AR2A,A
28600 MOVEI AR1,FT-1
28650 TLNE T,NEXP
28700 MOVEI AR1,FT01 ;-exponent
28750 PUSHJ P,FLOSUB
28800 FMPR TT,B ;positive exponent
28850 MOVEI B,FLONUM(S)
28900 MOVE A,TT
28950 JFCL 10,FLOOV
29000 JRST NUMAK6
29050
29100 FLOSUB: MOVSI B,(1.0)
29150 TRZE AR2A,1
29200 FMPR B,(AR1)
29250 JUMPE AR2A,CPOPJ
29300 LSH AR2A,-1
29350 SOJA AR1,FLOSUB+1
29400
29450 ;variable radix integer builder
29500
29550 NUM10: MOVEI A,TEN
29600 NUM: HRRM A,NUM1
29650 JFCL 10,.+1 ;clear carry0 flag
29700 SETZB A,AR2A
29750 NUM2: ILDB B,C
29800 JUMPE B,CPOPJ ;done
29850 IMUL A,NUM1#
29900 ADDI A,-"0"(B)
29950 NUM3: JFCL 10,FIXOV ;bignums change this to jfcl 10,rdbnm
30000 AOJA AR2A,NUM2
30050 PAGE
30100 INTERN: MOVEM A,AR2A
30150 PUSHJ P,PNAMUK
30200 PUSHJ P,IDSUB
30250 MOVEI AR1,1
30300 PUSHJ P,INTER1 ;is it in oblist
30350 POPJ P, ;found it
30400 MOVE A,AR2A ;not there
30450 JRST MAKID2 ;put it there
30500
30550 REMOB: JUMPE A,FALSE
30600 MOVEI AR1,1
30650 PUSH P,A
30700 HLRZ A,(A)
30750 PUSHJ P,INTERN
30800 HLRZ B,@(P)
30850 CAME A,B
30900 JRST REMOB2
30950 HRRZ B,CURBUC
31000 REMOTE<
31050 RHX5:
31100 XXX2: XWD B,OBTBL>
31150 HLRZ C,@RHX5
31200 HLRZ T,(C)
31250 CAMN T,A
31300 JRST [ HRRZ TT,(C)
31350 HRLM TT,@RHX5
31400 JRST REMOB2]
31450 REMOB3: MOVE TT,C
31500 HRRZ C,(C)
31550 HLRZ T,(C)
31600 CAME T,A
31650 JRST REMOB3
31700 HRRZ T,(C)
31750 HRRM T,(TT)
31800 REMOB2: POP P,A
31850 HRRZ A,(A)
31900 JRST REMOB
31950 PAGE
32000 ;ROUTINE TO ALLOW ARBITRARY MODIFICATION AND READING OF THE
32050 ;READ CHARACTER-TABLE BY LISP FUNCTIONS
32100 ;TAKES TWO ARGUMENTS A,B
32150 ; IF B = NIL IT RETURNS THE CONTENTS OF CHARACTER TABLE
32200 ; LOCATION SPECIFIED BY A
32250 ; OTHERWISE IT CHANGES THE CHARACTER TABLE ENTRY SPECIFIED BY A
32300 ; TO THE BIT PATTERN SPECIFIED BY B, AND RETURNS THE
32350 ; PREVIOUS VALUE
32400
32450 MODCHR: PUSH P,B ;$$SAVE BIT PATTERN FOR TABLE
32500 PUSHJ P,NUMVAL ;$$GET POSITION IN TABLE
32550 POP P,B ;$$
32600 MOVE T,CHRTAB(A) ;$$GET OLD TABLE VALUE
32650 JUMPE B,MCEXIT ;$$IF B=NIL THEN JUST RETURN OLD TABLE VALUE
32700 PUSH P,A ;$$SAVE TABLE POSITION
32750
32800 MOVEI A,(B) ;$$
32850 PUSHJ P,NUMVAL ;$$GET NEW BIT PATTERN
32900 POP P,B ;$$GET TABLE POSITION
32950 MOVEM A,CHRTAB(B) ;$$CHANGE TABLE
33000 MCEXIT: MOVE A,T ;$$RETURN OLD TABLE VALUE
33050 JRST FIX1A ;$$CONVERT TO BINARY AND EXIT
33100
33150 ;FUNCTION TO DETERMINE THE ASCII VALUE OF A CHARACTER
33200 ; CHRVAL TAKES AN ATOM AS ITS ARGUMENT AND USES THE FIRST
33250 ; CHARACTER OF THE PRINT NAME
33300 CHRVAL: MOVEI B,PNAME(S) ;$$ GET PRINT NAME
33350 PUSHJ P,GET ;$$
33400 HLRZ A,(A) ;$$
33450 MOVE A,(A) ;$$ FIRST WORD OF PRINT NAME
33500 LSH A,-35 ;$$ SHIFT TO GET FIRST CHARACTER
33550 JRST FIX1A ;$$ CONVERT TO INTEGER
33600
33650 ;FUNCTION TO SET BITS FOR A READ MACRO
33700 ; A IS THE CHAR. ATOM AND B ARE THE STATUS BITS,
33750 ; IF B=NIL NO MODIFICATION IS MADE
33800 ; THE OLD STATUS BITS ARE RETURNED
33850 SETCHR: MOVE TT,B ;$$
33900 PUSHJ P,CHRVAL ;$$ CONVERT CHAR. TO INUM
33950 MOVEI B,-INUM0(A) ;$$ CONVERT INUM TO BINARY
34000 LDB A,[POINT 5,CHRTAB(B),5] ;$$ LOAD OLD BITS
34050 JUMPE TT,FIX1A ;$$ NO CHANGE IF B = NIL
34100 MOVEI TT,-INUM0(TT) ;$$ CONVERT STATUS TO BINARY
34150 DPB TT,[POINT 5,CHRTAB(B),5] ;$$ SET NEW BITS
34200 JRST FIX1A ;$$ RETURN
34250
34300
34350 SUBTTL LISP INTERPRETER SUBROUTINES --- PAGE 10
34400 PAGE
34450
34500 CADDDR: SKIPA A,(A)
34550 CADDAR: HLRZ A,(A)
34600 CADDR: SKIPA A,(A)
34650 CADAR: HLRZ A,(A)
34700 CADR: SKIPA A,(A)
34750 CAAR: HLRZ A,(A)
34800 CAR: HLRZ A,(A)
34850 POPJ P,
34900
34950 CDDDDR: SKIPA A,(A)
35000 CDDDAR: HLRZ A,(A)
35050 CDDDR: SKIPA A,(A)
35100 CDDAR: HLRZ A,(A)
35150 CDDR: SKIPA A,(A)
35200 CDAR: HLRZ A,(A)
35250 CDR: HRRZ A,(A)
35300 POPJ P,
35350
35400 CAADDR: SKIPA A,(A)
35450 CAADAR: HLRZ A,(A)
35500 CAADR: SKIPA A,(A)
35550 CAAAR: HLRZ A,(A)
35600 JRST CAAR
35650
35700 CDADDR: SKIPA A,(A)
35750 CDADAR: HLRZ A,(A)
35800 CDADR: SKIPA A,(A)
35850 CDAAR: HLRZ A,(A)
35900 JRST CDAR
35950
36000 CAAADR: SKIPA A,(A)
36050 CAAAAR: HLRZ A,(A)
36100 JRST CAAAR
36150
36200 CDDADR: SKIPA A,(A)
36250 CDDAAR: HLRZ A,(A)
36300 JRST CDDAR
36350
36400 CDAADR: SKIPA A,(A)
36450 CDAAAR: HLRZ A,(A)
36500 JRST CDAAR
36550
36600 CADADR: SKIPA A,(A)
36650 CADAAR: HLRZ A,(A)
36700 JRST CADAR
36750 PAGE
36800
36850 QUOTE: HLRZ A,(A) ;car and quote duplicated for backtrace
36900 POPJ P,
36950
37000 AASCII: PUSHJ P,NUMVAL
37050 LSH A,↑D29
37100 PUSHJ P,FWCONS
37150 PUSHJ P,NCONS
37200 PNGNK1: PUSHJ P,NCONS
37250 MOVEI B,PNAME(S)
37300 PUSHJ P,XCONS
37350 ACONS: TROA B,-1
37400 NCONS: TRZA B,-1
37450 XCONS: EXCH B,A
37500 CONS: AOS CONSVAL
37550 HRL B,A
37600 SKIPN A,F
37650 JRST [ HLR A,B
37700 PUSHJ P,AGC
37750 JRST .-1]
37800 MOVE F,(F)
37850 MOVEM B,(A)
37900 POPJ P,
37950
38000 ;new consing routines-not finished yet
38050 ;acons: troa b,-1
38100 ;ncons: trz b,-1
38150 ;cons: exch b,a
38200 ;xcons: hrl a,b
38250 ; exch a,(f)
38300 ; exch a,f
38350 ; popj p,
38400
38450 CONSP: CAILE A,INUMIN
38500 JRST FALSE
38550 HLLE A,(A)
38600 AOJE A,FALSE
38650 JRST TRUE
38700 PATOM: CAIL A,@GCP1
38750 JRST TRUE
38800 CAIL A,@GCPP1
38850 ATOM: CAILE A,INUMIN
38900 JRST TRUE
38950 HLLE A,(A)
39000 AOJE A,TRUE
39050 JRST FALSE
39100 PAGE
39150 NEQ: CAMN A,B
39200 JRST FALSE
39250 JRST TRUE
39300 EQ: CAMN A,B
39350 JRST TRUE
39400 JRST FALSE
39450
39500 LENGTH: MOVEI B,0
39550 LNGTH1: CAILE A,INUMIN
39600 JRST FIX1
39650 HLLE C,(A)
39700 AOJE C,FIX1
39750 HRRZ A,(A)
39800 AOJA B,LNGTH1
39850
39900 LAST: HRRZ B,(A)
39950 CAILE B,INUMIN
40000 POPJ P,
40050 HLLE B,(B)
40100 AOJE B,CPOPJ
40150 HRRZ A,(A)
40200 JRST LAST
40250
40300 ;(LITATOM X) = (AND (ATOM X) (NOT (NUMBERP X)))
40350 LITATOM:MOVE B,A
40400 PUSHJ P,ATOM
40450 JUMPE A,CPOPJ
40500 MOVE A,B
40550 PUSHJ P,NUMBERP
40600 JRST NOT
40650 PAGE
40700 ;NEW RPLACD AND RPLACA WHICH CHECK SO AS NOT TO CLOBBER NIL AND ATOMS
40750 RPLACA: CAILE A,INUMIN ;$$
40800 JRST RPAERR ;$$ ATTEMPT TO RPLACA A SMALL NUMBER
40850 HLL A,(A) ;$$TEST FOR OTHER ATOMS
40900 TLC A,-1 ;$$
40950 TLZN A,-1 ;$$ATOM CARS ARE -1
41000 JRST RPAERR ;$$ATTEMPT TO RPLACA AN ATOM
41050 HRLM B,(A) ;$$STANDARD CODE FOR RPLACA
41100 POPJ P, ;$$
41150
41200 RPLACD: CAIG A,INUMIN ;$$CHECK FOR SMALL BER
41250 JUMPN A,.+2 ;$$CHECK FOR NIL
41300 JRST RPDERR ;$$ATTEMPT TO RPLACD NIL OR A SMALL NUMBER
41350 HRRM B,(A) ;$$OLD RPLACD CODE
41400 POPJ P, ;$$
41450
41500 ZEROP: PUSHJ P,NUMVAL
41550 NOT:
41600 NULL: JUMPN A,FALSE
41650 TRUE:
41700 MOVEI A,TRUTH(S)
41750 POPJ P,
41800
41850 FW0CNS: MOVEI A,0
41900 FWCONS: JUMPN FF,FWC1
41950 EXCH A,FWC0#
42000 PUSHJ P,AGC
42050 EXCH A,FWC0
42100 FWC1: EXCH A,(FF)
42150 EXCH A,FF
42200 POPJ P,
42250
42300 PAGE
42350 SASSOC: PUSHJ P,SAS1
42400 JCALLF 0,(C)
42450 POPJ P,
42500
42550 SAS0: HLRZ B,T
42600 SAS1: JUMPE B,CPOPJ
42650 MOVS T,(B)
42700 MOVS TT,(T)
42750 CAIE A,(TT)
42800 JRST SAS0
42850 HRRZ A,T
42900 CPOPJ1: AOS (P)
42950 POPJ P,
43000
43050 ASSOC: PUSHJ P,SAS1
43100 FALSE: MOVEI A,NIL
43150 CPOPJ: POPJ P,
43200
43250 REVERSE: MOVE T,A
43300 MOVEI A,0
43350 JUMPE T,CPOPJ
43400 HLRZ B,(T)
43450 HRRZ T,(T)
43500 PUSHJ P,XCONS
43550 JUMPN T,.-3
43600 POPJ P,
43650
43700
43750 REMPROP: HRRZ T,(A)
43800 MOVS TT,(T)
43850 CAIN B,(TT)
43900 JRA TT,REMP1
43950 HLRZ A,TT
44000 HRRZ T,(A)
44050 JUMPN T,REMPROP+1
44100 JRST FALSE
44150
44200 REMP1: HRRM TT,(A)
44250 JRST TRUE
44300 PAGE
44350 GET: HRRZ A,(A)
44400 MOVS D,(A)
44450 CAIN B,(D)
44500 JRST CADR
44550 HLRZ A,D
44600 HRRZ A,(A)
44650 JUMPN A,GET+1
44700 POPJ P,
44750
44800 GETL: JUMPE B,FALSE ;$$ NIL LIST - NIL ANSWER
44850 HRRZ A,(A)
44900 GETL0: HLRZ T,(A)
44950 MOVE C,B
45000 GETL1: MOVS TT,(C)
45050 CAIN T,(TT)
45100 POPJ P,
45150 HLRZ C,TT
45200 JUMPN C,GETL1
45250 HRRZ A,(A)
45300 HRRZ A,(A)
45350 JUMPN A,GETL0
45400 POPJ P,
45450
45500 NUMBERP: CAILE A,INUMIN
45550 JRST TRUE
45600 HLLE T,(A)
45650 AOJN T,FALSE
45700 HRRZ A,(A)
45750 HLRZ A,(A)
45800 CAIE A,FIXNUM(S)
45850 CAIN A,FLONUM(S)
45900 JRST TRUE
45950 NUMBP2: JRST FALSE ;bignums change this to JRST BIGNP
46000 STRINGP: MOVE B,A ;= T IF A IS A STRING
46050 PUSHJ P,ATOM
46100 JUMPE A,CPOPJ
46150 MOVE A,B
46200 PUSHJ P,NUMBERP ;MUST NO BE A NUMBER
46250 JUMPN A,FALSE
46300 MOVE A,B
46350 PUSHJ P,CHRVAL ;GET THE FIRST CHARACTER
46400 CAIE A,42+INUM0 ;CHECK FOR "
46450 JRST FALSE
46500 JRST TRUE
46550 PAGE
46600 PUTPROP: MOVE T,A
46650 HRRZ A,(A)
46700 CSET3: MOVS TT,(A)
46750 HLRZ A,TT
46800 CAIN C,(TT)
46850 JRST CSET2
46900 HRRZ A,(A)
46950 JUMPN A,CSET3
47000 HRRZ A,(T)
47050 PUSHJ P,XCONS
47100 HRRZ B,C
47150 PUSHJ P,XCONS
47200 HRRM A,(T)
47250 JRST CADR
47300
47350 CSET2:
47400 CAIE C,VALUE(S)
47450 JRST CSET1
47500 HRRZ T,(B)
47550 HLRZ A,(A)
47600 HRRM T,(A)
47650 JRST PROG2
47700
47750 CSET1: HRLM B,(A)
47800 PROG2: MOVE A,B
47850 PROG1: POPJ P,
47900
47950 DEFPROP:
48000 HRRZ B,(A)
48050 HRRZ C,(B)
48100 HLRZ A,(A)
48150 HLRZ B,(B)
48200 HLRZ C,(C)
48250 PUSH P,A
48300 PUSHJ P,PUTPROP
48350 JRST POPAJ
48400 PAGE
48450 EQUAL: MOVE C,P
48500 EQUAL1: CAMN A,B
48550 JRST TRUE
48600 MOVE T,A
48650 MOVE TT,B
48700 PUSHJ P,ATOM
48750 EXCH A,B
48800 PUSHJ P,ATOM
48850 CAMN A,B
48900 JRST EQUAL3
48950 EQUAL4: MOVE P,C
49000 JRST FALSE
49050
49100 EQUAL3: JUMPN A,EQ2
49150 PUSH P,T
49200 PUSH P,TT
49250 HLRZ A,(T)
49300 HLRZ B,(TT)
49350 PUSHJ P,EQUAL1
49400 JUMPE A,EQUAL4
49450 POP P,B
49500 POP P,A
49550 HRRZ A,(A)
49600 HRRZ B,(B)
49650 JRST EQUAL1
49700
49750 EQ2: PUSH P,T
49800 MOVE A,T
49850 PUSHJ P,NUMBERP
49900 JUMPE A,EQUAL4
49950 MOVE A,TT
00050 PUSHJ P,NUMBERP
00100 JUMPE A,EQUAL4
00150 MOVE A,(P)
00200 MOVEM C,(P)
00250 MOVE B,TT
00300 JSP C,OP
00350 JUMPL COMP3
00400 JUMPL COMP3
00450
00500 COMP3: POP P,C
00550 CAME A,TT
00600 JRST EQUAL4
00650 JRST TRUE
00700 PAGE
00750 SUBS5: HRRZ A,SUBAS
00800 POPJ P,
00850
00900 SUBST: MOVEM A,SUBAS#
00950 MOVEM B,SUBBS#
01000 SUBS0A: MOVE A,SUBAS
01050 MOVE B,SUBBS
01100 PUSH P,C
01150 MOVE A,C
01200 PUSHJ P,EQUAL
01250 POP P,C
01300 JUMPN A,SUBS5
01350 CAILE C,INUMIN
01400 JRST EV6A
01450 HLLE T,(C)
01500 AOJN T,SUBS2
01550 EV6A: MOVE A,C
01600 POPJ P,
01650
01700 SUBS2: PUSH P,C
01750 HLRZ C,(C)
01800 PUSHJ P,SUBS0A
01850 EXCH A,(P)
01900 HRRZ C,(A)
01950 PUSHJ P,SUBS0A
02000 POP P,B
02050 JRST XCONS
02100
02150 COPY: MOVEI B,INUM0 ;$$ (SUBST 0 0 A)
02200 MOVEI C,INUM0
02250 EXCH A,C
02300 JRST SUBST
02350
02400 ; NTHCHAR = THE BTH CHARACTER OF A.
02450 NTHCHAR:MOVE T,B
02500 SUBI T,INUM0
02550 JUMPE T,FALSE ;FAIL IF = 0
02600 PUSH P,A
02650 MOVEM T,ORGSGN
02700 JUMPG T,NTH3
02750 PUSHJ P,%FLATSIZEC
02800 MOVEI T,1-INUM0(A)
02850 ADDB T,ORGSGN
02900 NTH3: MOVE A,(P)
02950 PUSHJ P,LITATOM
03000 JUMPN A,NTH4
03050 POP P,A
03100 HRROI R,NTH5 ;I HOPE THIS IS RIGHT
03150 PUSHJ P,PRINTA
03200 HLRZ A,ORGSGN
03250 JRST NTH6
03300 NTH5: SOSN ORGSGN
03350 HRLOM A,ORGSGN
03400 POPJ P,
03450 NTH4: MOVE T,ORGSGN
03500 POP P,A
03550 MOVEI B,PNAME(S)
03600 PUSHJ P,GET
03650 JUMPE A,CPOPJ ;FAIL IF NO PRINT NAME
03700 NTH1: CAIG T,5
03750 JRST NTH2
03800 HRRZ A,(A)
03850 JUMPE A,FALSE ;FAIL IF NO NTH CHARACTER
03900 SUBI T,5
03950 JRST NTH1
04000 NTH2: HLRZ A,(A)
04050 IMULI T,-7
04100 LSH T,14
04150 ADDI T,440700
04200 HRL A,T
04250 LDB A,A
04300 JUMPE A,FALSE
04350 NTH6: PUSHJ P,AASCII+1 ;CONVERT TO AN ATOM
04400 JRST INTERN ;INTERN IT
04450 PAGE
04500 NCONC: TDZA R,R
04550 APPEND: MOVEI R,.APPEND-.NCONC
04600 JUMPE T,FALSE
04650 POP P,B
04700 APP2: AOJE T,PROG2
04750 POP P,A
04800 PUSHJ P,.NCONC(R)
04850 MOVE B,A
04900 JRST APP2
04950
05000 .NCONC: JUMPE A,PROG2
05050 MOVE TT,A
05100 MOVE C,TT
05150 HRRZ TT,(C)
05200 JUMPN TT,.-2
05250 HRRM B,(C)
05300 POPJ P,
05350
05400 .APPEND: JUMPE A,PROG2
05450 MOVEI C,AR1
05500 MOVE TT,A
05550 APP1: HLRZ A,(TT)
05600 PUSH P,B
05650 PUSHJ P,CONS ;saves b
05700 POP P,B
05750 HRRM A,(C)
05800 MOVE C,A
05850 HRRZ TT,(TT)
05900 JUMPN TT,APP1
05950 JRST SUBS4
06000 PAGE
06050 MEMBER: MOVEM A,SUBAS
06100 MEMB1: JUMPE B,FALSE
06150 MOVEM B,SUBBS
06200 MOVE A,SUBAS
06250 HLRZ B,(B)
06300 PUSHJ P,EQUAL
06350 JUMPN A,CPOPJ
06400 MOVE B,SUBBS
06450 HRRZ B,(B)
06500 JRST MEMB1
06550
06600 MEMQ: JUMPE B,FALSE
06650 MOVS C,(B)
06700 CAIN A,(C)
06750 JRST TRUE
06800 HLRZ B,C
06850 JUMPN B,MEMQ+1
06900 JRST FALSE
06950
07000
07050
07100 ;NEW MEM-FUNCTIONS THAT RETURN THE TAIL OF THE LIST STARTING WHERE
07150 ; THE ELEMENT IS FOUND
07200
07250 MEMBR.: PUSHJ P,MEMBER
07300 SKIPE A
07350 MOVE A,SUBBS
07400 POPJ P,
07450
07500 MEMB: PUSHJ P,MEMQ
07550 SKIPE A
07600 MOVE A,B
07650 POPJ P,
07700
07750
07800 ;NEW AND AND OR FUNCTIONS (AND#, OR#) THAT RETURN THE EXPRESSION
07850 ; THAT CAUSED THE FUNCTION TO EVALUATE TO TRUE
07900
07950 AND.: PUSHJ P,AND
08000 SKIPA
08050 OR.: PUSHJ P,OR
08100 HRRZ A,2(P)
08150 POPJ P,
08200
08250 AND:
08300 HRLI A,TRUTH(S)
08350 OR: HLRZ C,A
08400 PUSH P,C
08450 ANDOR: HRRZ C,A
08500 JUMPE C,AOEND
08550 MOVSI C,(SKIPE (P))
08600 TLNE A,-1
08650 MOVSI C,(SKIPN (P))
08700 XCT C
08750 JRST AOEND
08800 MOVEM A,(P)
08850 HLRZ A,(A)
08900 PUSHJ P,EVAL
08950 EXCH A,(P)
09000 HRR A,(A)
09050 JRST ANDOR
09100
09150 AOEND: POP P,A
09200 SKIPE A
09250 MOVEI A,TRUTH(S)
09300 POPJ P,
09350 GENSYM: MOVE B,[POINT 7,GNUM,34]
09400 MOVNI C,4
09450 MOVEI TT,"0"
09500
09550 GENSY2: LDB T,B
09600 AOS T
09650 DPB T,B
09700 CAIG T,"9"
09750 JRST GENSY1
09800 DPB TT,B
09850 ADD B,[XWD 70000,0]
09900 AOJN C,GENSY2
09950
10000 GENSY1: MOVE A,GNUM
10050 PUSHJ P,FWCONS
10100 PUSHJ P,NCONS
10150 JRST PNGNK1
10200
10250 REMOTE<
10300 GNUM: ASCII /G0000/>
10350
10400 CSYM: HLRZ A,(A)
10450 PUSH P,A
10500 MOVEI B,PNAME(S)
10550 PUSHJ P,GET
10600 JUMPE A,NOPNAM
10650 HLRZ A,(A)
10700 MOVE A,(A)
10750 MOVEM A,GNUM
10800 JRST POPAJ
10850 PAGE
10900 LIST: MOVEI B,CEVAL(S)
10950 PUSH P,B
11000 PUSH P,A
11050 MOVNI T,2
11100 JRST MAPCAR
11150
11200 EELS: HLRZ TT,(T) ;interpret lsubr call
11250 HRRZ A,(AR1)
11300 ILIST: MOVEI T,0
11350 JUMPE A,ILIST2
11400 ILIST1: PUSH P,A
11450 HLRZ A,(A)
11500 PUSH P,TT
11550 HRLM T,(P)
11600 PUSH P,SP ;$$SAVE SP POINTER TO RESTORE AFTER ARGUMENT EVALUATED
11650 PUSHJ P,EVAL ;EVALUATE ARGUMENT
11700 POP P,SP ;$$RESTORE SP POINTER AFTER EVAL
11750 ILIST3: POP P,TT
11800 HLRE T,TT
11850 EXCH A,(P)
11900 HRRZ A,(A)
11950 SOS T
12000 JUMPN A,ILIST1
12050 ILIST2: JRST (TT)
12100
12150 ;FAST MAPC FOR 2 ARGS - CALLED BY LAP CODE ONLY
12200 .MAPC: PUSH P,A
12250 JUMPE B,PRETB
12300 HLRZ A,(B)
12350 HRRZ B,(B)
12400 PUSH P,B
12450 CALLF 1,@-1(P)
12500 POP P,B
12550 JRST .MAPC+1
12600
12650 ;FAST MAP FOR 2 ARGS - CALLED BY LAP CODE ONLY
12700 .MAP: PUSH P,A
12750 JUMPE B,PRETB
12800 MOVE A,B
12850 HRRZ B,(B)
12900 PUSH P,B
12950 CALLF 1,@-1(P)
13000 POP P,B
13050 JRST .MAP+1
13100
13150 PRETB: SUB P,[XWD 1,1]
13200 JRST PROG2
13250 PAGE
13300 ; NEW AND SUPER POWERFUL MAP FUNCTIONS
13350 MAPCON: TLZ T,100000
13400 JRST MAPLIST
13450 MAPCAN: TLZA T,100000
13500 MAPC: TLZA T,400000
13550 MAPCAR: TLZA T,400000
13600 MAP: TLZ T,200000
13650 ; INITIALIZE
13700 MAPLIST:SETCA T,T
13750 MOVEI A,(CALLF)
13800 DPB T,[POINT 4,A,30]
13850 MOVE B,P
13900 MOVE AR1,T
13950 HRL AR1,T
14000 SUB B,AR1
14050 PUSH P,B
14100 HRLM A,(B)
14150 PUSH P,T
14200 PUSH P,
14250 HRLZM P,(P)
14300 ; SET UP TO GET ARGUMENTS
14350 MAPL2: HRRZ T,-1(P)
14400 MOVEI TT,-3(P)
14450 ; MOVE ARGS TO REGS
14500 MPL3: MOVE D,(TT)
14550 JUMPE D,MPDN
14600 MOVEM D,(T)
14650 MOVE D,(D)
14700 SKIPGE -1(P)
14750 HLRZM D,(T)
14800 HRRZM D,(TT)
14850 SUBI TT,1
14900 SOJG T,MPL3
14950 XCT (TT) ; CALL THE FUNCTION
15000 LDB C,[POINT 2,-1(P),2]
15050 TRNE C,2
15100 JRST MAPL2
15150 ; ATTACH TO OUTPUT LIST
15200 SKIPN C
15250 PUSHJ P,NCONS
15300 JUMPE A,MAPL2
15350 HLR B,(P)
15400 HRRM A,(B)
15450 SKIPE C
15500 PUSHJ P,LAST
15550 HRLM A,(P)
15600 JRST MAPL2
15650 ; POP STACK AND RETURN
15700 MPDN: POP P,AR1
15750 MOVE P,-1(P)
15800 POP P,B
15850 SUBS4: HRRZ A,AR1
15900 POPJ P,
15950 ;PA3: 0 ;THE REG. PDL POINTER
16000 ;PA4: 0 ;Lh=pntr to prog less bound var list
16050 ;RH=NEXT PROG STATEMENT
16100
16150 PROG: PUSH P,PA3#
16200 PUSH P,PA4#
16250 HLRZ TT,(A)
16300 HRRZ A,(A)
16350 HRRM A,PA4
16400 HRLM A,PA4
16450
16500 MOVE T,SP ;$$ADJUST SPDLSAV POINTER TO INCLUDE EVAL BLIP
16550 SUB T,[XWD 2,2] ;$$SO PA3,PA4 CAN BE RESTORED
16600 MOVEM T,SPSV# ;$$BY UNBIND
16650 JRST PG7B ;$$GO CHECK IF ANY VARIABLES TO BIND
16700
16750 PG7A: HLRZ A,(TT)
16800 MOVEI AR1,0
16850 PUSHJ P,BIND
16900 HRRZ TT,(TT)
16950 PG7B: JUMPN TT,PG7A
17000 PUSH SP,SPSV
17050 MOVEM P,PA3
17100
17150 PG1: HRRZ T,PA4
17200 JUMPE T,PG4
17250 HLRZ A,(T)
17300 HRRZ T,(T)
17350 HLLE B,(A)
17400 AOJE B,PG1+1
17450 HRRM T,PA4
17500
17550 PUSH P,SP ;$$SAVE SPDL TO RESTORE AFTER EVAL
17600 PUSHJ P,EVAL
17650 POP P,SP ;$$RESTORE SPDL AFTER EVAL
17700
17750 JRST PG1
17800
17850 PGO: SKIPN PA3
17900 JRST EG2
17950 MOVE P,PA3
18000 MOVE B,1(P)
18050 PUSHJ P,UBD
18100 HLRZ T,PA4
18150 PG5: JUMPE T,EG1
18200 HLRZ TT,(T)
18250 HRRZ T,(T)
18300 CAIN TT,(A)
18350 JRST PG1+1 ;FOUND TAG
18400 JRST PG5
18450
18500 RETURN: SKIPN PA3
18550 JRST EG3
18600 MOVE P,PA3
18650 MOVE B,1(P)
18700 PUSHJ P,UBD
18750 JRST PG4+1
18800 PG4: SETZ A,
18850 PUSHJ P,UNBIND
18900 ERRP4: POP P,PA4
18950 POP P,PA3
19000 POPJ P,
19050
19100 GO: HLRZ A,(A)
19150 HLLE B,(A)
19200 AOJE B,PGO
19250 PUSHJ P,EVAL
19300 JRST GO+1
19350
19400
19450 SETQ: HLRZ B,(A)
19500 PUSH P,B
19550 PUSHJ P,CADR
19600 PUSHJ P,EVAL
19650 MOVE B,A
19700 POP P,A
19750 SET: SKIPE A ;$$ MUST BE NON-NIL
19800 CAILE A,INUMIN ;$$ AND NOT AN INUM
19850 JRST SETERR ;$$
19900 HLRE AR1,(A) ;$$ AND AN ATOM
19950 AOJN AR1,SETERR ;$$
20000 MOVE AR1,B
20050 PUSHJ P,BIND
20100 SUB SP,[XWD 1,1]
20150 MOVE A,AR1
20200 POPJ P,
20250
20300 CON2: HRRZ A,(T)
20350 COND: JUMPE A,CPOPJ ;entry
20400 PUSH P,A
20450 HLRZ A,(A)
20500 HLRZ A,(A)
20550 PUSHJ P,EVAL
20600 POP P,T
20650 JUMPE A,CON2
20700 HLRZ T,(T)
20750 COND2: HRRZ T,(T)
20800 JUMPE T,CPOPJ ;ENTRY FOR ALL TYPES OF PROGN'S
20850 HLRZ A,(T)
20900 HRRZ T,(T) ;$$
20950 JUMPE T,EVAL ;$$ SAVE STACK SPACE IF NO IMPLIED PROG
21000 PUSH P,T ;$$
21050 PUSHJ P,EVAL
21100 POP P,T
21150 JRST COND2+2 ;$$ BECAUSE OF THE LAST CHANGE
21200
21250
21300 ;LEXORDER - TRUE IF A IS ALPHAMERICALLY LESS THAT OR EQUAL TO B
21350
21400 LEXORD: MOVE TT,A
21450 PUSHJ P,NUMBERP
21500 JUMPN A,LEX2 ;1ST ARG IS A NUMBER
21550 MOVE A,B
21600 PUSHJ P,NUMBERP
21650 EXCH A,TT
21700 JUMPN TT,FALSE ;1ST=NOT-NUM, 2ND=NUM, DEFINE AS NIL
21750 MOVE T,B
21800 MOVEI B,PNAME(S)
21850 PUSHJ P,GET
21900 EXCH A,T
21950 PUSHJ P,GET
22000 LEX1: JUMPE T,TRUE
22050 JUMPE A,CPOPJ
22100 HLRZ AR1,(A)
22150 MOVE AR1,(AR1)
22200 HLRZ AR2A,(T)
22250 MOVE AR2A,(AR2A)
22300 LSH AR1,-1
22350 LSH AR2A,-1
22400 CAMLE AR1,AR2A
22450 JRST TRUE
22500 CAME AR1,AR2A
22550 JRST FALSE
22600 HRRZ A,(A)
22650 HRRZ T,(T)
22700 JRST LEX1
22750 LEX2: MOVE A,B
22800 PUSHJ P,NUMBERP
22850 EXCH A,TT
22900 JUMPE TT,TRUE ;1ST=NUM, 2ND=NOT-NUM, DEFINE AS TRUE
22950 PUSHJ P,.GREAT ;BOTH NUMBERS, DO (NOT (*GREAT A B))
23000 JRST NOT
23050
23100
23150 PROGN: MOVE T,A ;$$ PROGN
23200 MOVEI A,NIL
23250 JRST COND2+1 ;$$ IMPLIED PROG DOES THE REST
23300 PAGE
23350 SUBTTL ARITHMETIC SUBROUTINES --- PAGE 11
23400
23450 ;macro expander -- (foo a b c) => (*foo (*foo a b) c)
23500 EXPAND: MOVE C,B
23550 HRRZ A,(A)
23600 PUSHJ P,REVERSE
23650 JRST EXPA1
23700
23750 EXPN1: MOVE C,B
23800 EXPA1: HRRZ T,(A)
23850 HLRZ A,(A)
23900 JUMPE T,CPOPJ
23950 PUSH P,A
24000 MOVE A,T
24050 PUSHJ P,EXPA1
24100 EXCH A,(P)
24150 PUSHJ P,NCONS
24200 POP P,B
24250 PUSHJ P,XCONS
24300 MOVE B,C
24350 JRST XCONS
24400
24450 PAGE
24500
24550 ADD1: CAILE A,INUMIN
24600 CAIL A,-2
24650 SKIPA B,[INUM0+1]
24700 AOJA A,CPOPJ
24750 .PLUS: JSP C,OP
24800 ADD A,TT
24850 FADR A,TT
24900
24950 SUB1: CAILE A,INUMIN+1
25000 SOJA A,CPOPJ
25050 MOVEI B,INUM0+1
25100 .DIF: JSP C,OP
25150 SUB A,TT
25200 FSBR A,TT
25250
25300 .TIMES: JSP C,OP
25350 IMUL A,TT
25400 FMPR A,TT
25450
25500 .QUO: CAIN B,INUM0
25550 JRST ZERODIV
25600 JSP C,OP
25650 IDIV A,TT
25700 FDVR A,TT
25750
25800 .GREAT: EXCH A,B
25850 JUMPE B,FALSE
25900 .LESS: JUMPE A,CPOPJ
25950 JSP C,OP
26000 JRST COMP2 ;bignums know about me
26050 JRST COMP2
26100
26150 COMP2: CAML A,TT
26200 JRST FALSE
26250 JRST TRUE
26300
26350 .MAX: MOVEI D,.GREAT
26400 SKIPA
26450 .MIN: MOVEI D,.LESS
26500 MOVE AR1,A
26550 MOVE AR2A,B
26600 PUSHJ P,(D)
26650 SKIPN A
26700 MOVE AR1,AR2A
26750 MOVE A,AR1
26800 POPJ P,
26850 PAGE
26900 MAKNUM:
26950 CAIN B,FIXNUM(S)
27000 JRST FIX1A
27050 FLO1A:
27100 MOVEI B,FLONUM(S)
27150 PUSHJ P,FWCONS
27200 JRST ACONS-1
27250
27300 FIX1B: SUBI A,INUM0
27350 MOVEI B,FIXNUM(S)
27400 PUSHJ P,FWCONS
27450 JRST ACONS-1
27500
27550 NUMVLX: JFCL 17,.+1
27600 NUMVAL: CAIG A,INUMIN
27650 JRST NUMAG1
27700 SUBI A,INUM0
27750 MOVEI B,FIXNUM(S)
27800 POPJ P,
27850
27900 NUMAG1: MOVEM A,AR1
27950 HRRZ A,(A)
28000 HLRZ B,(A)
28050 HRRZ A,(A)
28100 CAIE B,FIXNUM(S)
28150 CAIN B,FLONUM(S)
28200 SKIPA A,(A)
28250 NUMV4: SKIPA A,AR1
28300 POPJ P,
28350 NUMV2: PUSHJ P,EPRINT ;bignums know about me
28400 JRST NONNUM
28450
28500 NUMV3: JRST NONNUM ;bignums change me to JRST BIGDIS
28550 PAGE
28600 FLOAT: IDIVI A,400000
28650 SKIPE A
28700 TLC A,254000
28750 TLC B,233000
28800 FADR A,B
28850 POPJ P,
28900
28950 FIX: PUSH P,A
29000 PUSHJ P,NUMVAL
29050 CAIE B,FLONUM(S)
29100 JRST POPAJ
29150 MULI A,400
29200 TSC A,A
29250 JFCL 17,.+1
29300 ASH B,-243(A)
29350 FIX2: JFCL 10,FIXOV ;bignums change me to jfcl 10,bfix
29400 POP P,A
29450 FIX1: MOVE A,B
29500 JRST FIX1A
29550
29600 MINUSP: PUSHJ P,NUMVAL
29650 JUMPGE A,FALSE
29700 JRST TRUE
29750
29800 MINUS: PUSHJ P,NUMVLX
29850 MOVNS A
29900 JFCL 10,@OPOV
29950 JRST MAKNUM
30000
30050 ABS: PUSHJ P,NUMVLX
30100 MOVMS A
30150 JRST MINUS+2
30200 PAGE
30250 DIVIDE: CAIN B,INUM0
30300 JRST ZERODIV
30350 JSP C,OP
30400 JUMPN RDIV ;bignums know about me
30450 JRST ILLNUM
30500 RDIV: IDIV A,TT
30550 PUSH P,B
30600 PUSHJ P,FIX1A
30650 EXCH A,(P)
30700 PUSHJ P,FIX1A
30750 POP P,B
30800 JRST XCONS
30850
30900 REMAINDER:
30950 PUSHJ P,DIVIDE
31000 JRST CDR
31050
31100 FIXOV: ERR1 [SIXBIT /INTEGER OVERFLOW!/]
31150 ZERODIV:ERR1 [SIXBIT /ZERO DIVISOR!/]
31200 FLOOV: ERR1 [SIXBIT /FLOATING OVERFLOW!/]
31250 ILLNUM: ERR1 [SIXBIT /NON-INTEGRAL OPERAND!/]
31300
31350 GCD: JSP C,OP
31400 JUMPA GCD2 ;bignums know about me
31450 JRST ILLNUM
31500 GCD2: MOVMS A
31550 MOVMS TT
31600 ;euclid's algorithm
31650 GCD3: CAMG A,TT
31700 EXCH A,TT
31750 JUMPE TT,FIX1A
31800 IDIV A,TT
31850 MOVE A,B
31900 JRST GCD3
31950 PAGE
32000 ;general arithmetic op code routine for mixed types
32050
32100 OP: CAIG A,INUMIN
32150 JRST OPA1
32200 SUBI A,INUM0
32250 CAIG B,INUMIN
32300 JRST OPA2
32350 HRREI TT,-INUM0(B)
32400 XCT (C) ;inum op (cannot cause overflow)
32450 FIX1A: ADDI A,INUM0
32500 CAILE A,INUMIN
32550 CAIL A,-1
32600 JRST FIX1B
32650 POPJ P,
32700
32750 OPA1: HRRZ A,(A)
32800 HLRZ T,(A)
32850 HRRZ A,(A)
32900 CAIE T,FIXNUM(S)
32950 JRST OPA6
33000 SKIPA A,(A)
33050 OPA2:
33100 MOVEI T,FIXNUM(S)
33150 CAILE B,INUMIN
33200 JRST OPB2
33250 HRRZ B,(B)
33300 HRRZ TT,(B)
33350 HLRZ B,(B)
33400 CAIE B,FIXNUM(S)
33450 JRST OPA5
33500 SKIPA TT,(TT)
33550 OPB2: HRREI TT,-INUM0(B)
33600 MOVE AR1,A
33650 JFCL 17,.+1
33700 XCT (C) ;fixed pt op
33750 OPOV: JFCL 10,FIXOV ;bignums change this to jfcl 10,fixovl
33800 JRST FIX1A
33850
33900 OPA6: CAILE B,INUMIN
33950 JRST OPB7
34000 HRRZ B,(B)
34050 HRRZ TT,(B)
34100 HLRZ B,(B)
34150 CAIE B,FLONUM(S)
34200 JRST OPB3
34250 CAIE T,FLONUM(S)
34300 JRST NUMV3
34350 MOVE A,(A)
34400 MOVE TT,(TT)
34450 OPR: JFCL 17,.+1
34500 XCT 1(C) ;flt pt op
34550 JFCL 10,FLOOV
34600 JRST FLO1A
34650
34700 OPA5:
34750 CAIE B,FLONUM(S)
34800 JRST NUMV3
34850 PUSHJ P,FLOAT
34900 JRST OPR-1
34950
35000 OPB3:
35050 CAIE B,FIXNUM(S)
35100 JRST NUMV3
35150 SKIPA TT,(TT)
35200 OPB7: HRREI TT,-INUM0(B)
35250 MOVEI B,FIXNUM(S)
35300 CAIE T,FLONUM(S)
35350 JRST NUMV3
35400 MOVE A,(A)
35450 EXCH A,TT
35500 PUSHJ P,FLOAT
35550 EXCH A,TT
35600 JRST OPR
00050 SUBTTL EXPLODE, READLIST AND FRIENDS --- PAGE 12
00100
00150 %FLATSIZEC: SKIPA R,.+1 ;$$ FLATSIZEC - (LENGTH (EXPLODEC))
00200 FLATSIZE: HRRZI R,FLAT2
00250 SETZM FLAT1
00300 PUSHJ P,PRINTA
00350 MOVE A,FLAT1#
00400 JRST FIX1A
00450 FLAT2: AOS FLAT1
00500 POPJ P,
00550
00600
00650 %EXPLODE: SKIPA R,.+1
00700 EXPLODE: HRRZI R,EXPL1
00750 MOVSI AR1,AR1
00800 PUSHJ P,PRINTA
00850 JRST SUBS4
00900
00950 EXPL1: PUSH P,B
01000 PUSH P,C
01050 ANDI A,177
01100 CAIL A,"0"
01150 CAILE A,"9"
01200 JRST EXPL2
01250 ADDI A,INUM0-"0"
01300 JRST EXPL4
01350
01400 EXPL2: PUSH P,AR1
01450 PUSH P,TT
01500 PUSH P,T
01550 LSH A,35
01600 MOVE C,SP
01650 PUSH C,A
01700 MOVEI AR1,1
01750 PUSHJ P,INTER0
01800 POP P,T
01850 POP P,TT
01900 POP P,AR1
01950 EXPL4: PUSHJ P,NCONS
02000 HLR B,AR1
02050 HRRM A,(B)
02100 HRLM A,AR1
02150 POP P,C
02200 JRST POPBJ
02250 PAGE
02300 READLIST: TDZA T,T
02350 MAKNAM: MOVNI T,1
02400 MOVEM T,NOINFG
02450 PUSH P,OLDCH
02500 SETZM OLDCH
02550 JUMPE A,NOLIST
02600 HRRM A,MKNAM3
02650 MOVEI A,MKNAM2
02700 PUSHJ P,READ0
02750 HRRZ T,MKNAM3
02800 CAIE T,-1
02850 JUMPN T,[ERR1 [SIXBIT /MORE THAN ONE S-EXPRESSION-MKNAM!/]]
02900 POP P,OLDCH
02950 POPJ P,
03000
03050 MKNAM2: PUSH P,B
03100 PUSH P,T
03150 PUSH P,TT
03200 HRRZ TT,MKNAM3#
03250 JUMPE TT,MKNAM6
03300 CAIN TT,-1
03350 ERR1 [SIXBIT /READ UNHAPPY-MAKNAM!/]
03400 HRRZ B,(TT)
03450 HRRM B,MKNAM3
03500 HLRZ A,(TT)
03550 CAIGE A,INUMIN
03600 JRST MKNAM5
03650 SUBI A,INUM0-"0"
03700 MKNAM4: POP P,TT
03750 POP P,T
03800 JRST POPBJ
03850
03900 MKNAM5: HLRZ A,(TT)
03950 MOVEI B,PNAME(S)
04000 PUSHJ P,GET
04050 HLRZ A,(A)
04100 LDB A,[POINT 7,(A),6]
04150 JRST MKNAM4
04200
04250 MKNAM6: MOVEI A," "
04300 HLLOS MKNAM3
04350 JRST MKNAM4
04400
04450 ; A COUPLE OF FUNCTIONS SO THAT THE PROGRAMMER MAY RETURN CELLS TO THE FREE LIST
04500 FREE: MOVEM F,(A) ;$$ RETURN A SINGLE CELL TO FREE LIST
04550 HRRZ F,A
04600 JRST FALSE
04650 FREELI: JUMPE A,CPOPJ ;$$ RETURN A LIST TO THE FREE LIST
04700 HRRZ B,(A)
04750 MOVEM F,(A)
04800 HRRZ F,A
04850 MOVE A,B
04900 JRST FREELI
00050
00100
00150 APPLY.: CAILE A,INUMIN ;$$ AN APPLY TO HANDLE ANY FUNCTION TYPE
00200 JRST UNDTAG
00250 HLRZ T,(A)
00300 CAIE T,-1
00350 JRST GAPP
00400 HRRZ T,(A)
00450 AAGN: JUMPE T,GAPP
00500 HLRZ TT,(T)
00550 HRRZ T,(T)
00600 CAIN TT,FSUBR(S)
00650 JRST [MOVE A,B
00700 HLRZ T,(T)
00750 JRST (T)]
00800 CAIN TT,FEXPR(S)
00850 JRST [ HLRZ T,(T)
00900 HRL T,A
00950 PUSH P,T
01000 MOVE A,B
01050 JRST APPL.2]
01100 CAIN TT,MACRO(S)
01150 JRST [ PUSHJ P,CONS
01200 JRST EVAL]
01250 CAIN TT,EXPR(S)
01300 JRST GAPP
01350 CAIN TT,SUBR(S)
01400 JRST GAPP
01450 CAIE TT,LSUBR(S)
01500 JRST AAGN
01550 GAPP: HRREI T,-2
01600 PUSH P,A
01650 PUSH P,B
01700 JRST APPLY
01750
01800 SUBTTL EVAL APPLY -- THE INTERPRETER --- PAGE 13
01850 EV3: HLRZ A,(AR1)
01900 MOVEI B,VALUE(S)
01950 PUSHJ P,GET
02000 JUMPE A,UNDFUN ;function object has no definition
02050 HRRZ A,(A)
02100 REMOTE<
02150 XXX4:
02200 UBDPTR: UNBOUND>
02250 HLRZ B,(AR1) ;$$GET ORIGINAL FN NAME
02300 CAME A,B ;$$IF VALUE IS THE SAME THE WE HAVE A LOOP
02350 CAMN A,UBDPTR
02400 JRST UNDFUN
02450 HRRZ B,(AR1) ;eval (cons (cdr a)(cdr ar1))
02500 PUSHJ P,CONS
02550 JRST XXEVAL
02600 PAGE
02650 OEVAL: AOJN T,AEVAL
02700 POP P,A
02750 EVAL: PUSH P,SP ;$$SAVE SPDL
02800 PUSHJ P,XXEVAL ;$$GO DO EVALUATION AS USUAL
02850 POP P,SP ;$$RESTORE SPDL
02900 POPJ P, ;$$AND RETURN TO CALLER
02950
03000 XXEVAL: HRRZM A,AR1
03050 CAILE A,INUMIN
03100 JRST CPOPJ
03150
03200 ;$$CODE TO PUT EVAL BLIP ON SPECIAL PDL
03250
03300 PUSH P,B ;$$SAVE WHAT WAS IN B
03350 HRRZI B,-1(P) ;$$GET RPDL POINTER AND OFFSET
03400 HRLI B,UNBOUND(S) ;$$ SET UP RPDL POINTER
03450 PUSH SP,B ;$$ SAVE RPDL POINTER ON SPDL
03500 PUSH SP,A ;$$SAVE EVAL FORM ON SPDL
03550 POP P,B ;$$AND GO OON
03600 HLRZ T,(A) ;;;;;;;;;;;;;
03650
03700
03750 SKIPN ERINT# ;$$CHECK IF DDT (CONTROL H) INTERRUPT OCCURRED
03800 JRST .+4 ;$$SKIP OVER INTERRUPT FEATURE
03850 SETZM ERINT# ;$$TURN OFF INTERRUPT FLAG
03900 PUSHJ P,EPRINT ;$$PRINT OUT WHAT WAS INTERRUPTED
03950 ERR1 [SIXBIT /WAS JUST INTERRUPTED - NOW IN ERRORX!/]
04000
04050 CAIN T,-1
04100 JRST EE1 ;x is atomic
04150 CAILE T,INUMIN
04200 JRST UNDFUN
04250
04300
04350 HLRO TT,(T)
04400 AOJE TT,EE2 ;car (x) is atomic
04450 JRST EXP3
04500
04550 EE1:
04600 EV5: HRRZ AR1,(AR1)
04650 JUMPE AR1,UNBVAR
04700 HLRZ TT,(AR1)
04750 CAIE TT,FLONUM(S)
04800 CAIN TT,FIXNUM(S)
04850 POPJ P,
04900 EVBIG: HRRZ AR1,(AR1) ;bignums know about me
04950 CAIE TT,VALUE(S)
05000 JRST EV5
05050 HLRZ AR1,(AR1)
05100 HRRZ AR1,(AR1)
05150 CAIN AR1,UNBOUND(S)
05200 JRST UNBVAR
05250 MOVEM AR1,A
05300 POPJ P,
05350 PAGE
05400 ; HANDLER OF ALISTS AND SPDL CONTEXT POINTERS
05450
05500 ALIST: SKIPE A,-1(P)
05550 PUSHJ P,NUMBERP
05600 MOVEM SP,SPSV
05650 JUMPN A,AEVAL7 ;number
05700 MOVE C,SC2 ;bottom of spec pdl
05750 MOVEM C,AEVAL5#
05800 SETOM AEVAL2
05850 AEVAL8: MOVE C,SP
05900 AEVAL6: CAMN C,AEVAL5 ;bottom spec pdl
05950 JRST AEVAL1 ;done
06000 POP C,T ;pointer for next block
06050 JUMPGE T,AEVAL6 ;$$SKIP ANY EVAL BLIP CRAP
06100 AEVAL4: CAMN C,T
06150 JRST AEVAL6 ;thru with block
06200 POP C,AR1
06250 TLNE AR1,-1 ;$$ TEST FOR EVAL BLIP
06300 JRST .+3
06350 SUB C,[XWD 1,1] ;$$ FOUND ONE, SKIP RPDL WORD
06400 JRST AEVAL4
06450 MOVSS AR1
06500 PUSH SP,(AR1) ;save value cell
06550 HLRM AR1,(AR1) ;store previous value in value cell
06600 HRLM AR1,(SP) ;save pointer to spec pdl loc
06650 JRST AEVAL4
06700
06750 AEVAL: PUSHJ P,ALIST
06800 POP P,A
06850 MOVEI A,UNBIND
06900 EXCH A,(P)
06950 JRST EVAL
07000 PAGE
07050 AEVAL1: SKIPGE AEVAL2
07100 SKIPN B,-1(P)
07150 JRST ABIND3 ;done with binding
07200
07250 ;alist binding
07300 MOVE A,B
07350 PUSHJ P,REVERSE
07400 SKIPA
07450 ABIND2: MOVE A,B
07500 HRRZ B,(A)
07550 HLRZ A,(A)
07600 HRRZ AR1,(A)
07650 HLRZ A,(A)
07700 PUSHJ P,BIND
07750 JUMPN B,ABIND2
07800 ABIND3: PUSH SP,SPSV
07850 POPJ P,
07900
07950 ;spec pdl binding
08000 AEVAL7: MOVE A,-1(P)
08050 PUSHJ P,NUMVAL
08100 JUMPL A,.+5 ;MAKE SURE IT IS A VALID STACK POINTER
08150 MOVS T,SC2 ;IT'S NOT, MAKE IT VALID
08200 ADD T,A
08250 ADD A,SC2
08300 HRL A,T
08350 CLEARM AEVAL2#
08400 MOVEM A,AEVAL5 ;point to unbind to
08450 JRST AEVAL8
08500
08550 ;AEVAL2: 0 ;0 for number, -1 for a-list
08600 PAGE
08650
08700 EE2: HRRZ T,(T)
08750 JUMPE T,EV3
08800 HLRZ TT,(T)
08850 HRRZ T,(T)
08900 CAIN TT,SUBR(S)
08950 JRST ESB
09000 CAIN TT,LSUBR(S)
09050 JRST EELS
09100 CAIN TT,EXPR(S)
09150 JRST AEXP
09200 CAIN TT,FSUBR(S)
09250 JRST EFS
09300 CAIN TT,MACRO(S)
09350 JRST EFM
09400 CAIE TT,FEXPR(S)
09450 JRST EE2
09500
09550 HLRZ T,(T)
09600 HLL T,(AR1)
09650 PUSH P,T
09700 HRRZ A,(A)
09750 APPL.2: TLO A,400000
09800 PUSH P,A
09850 MOVNI T,1
09900 JRST IAPPLY
09950
10000 AEXP: HLRZ T,(T)
10050 HLL T,(AR1)
10100 EXP3: PUSH P,T
10150 HRRZ A,(AR1)
10200 CILIST: JSP TT,ILIST
10250 EXP2: JRST IAPPLY
10300
10350 EFS: HLRZ T,(T)
10400 HRRZ A,(AR1)
10450 JRST (T)
10500 PAGE
10550 ESB: HRRZ A,(AR1)
10600 UUOS2: HLRZ T,(T)
10650 HLL T,(AR1)
10700 PUSH P,T
10750 JSP TT,ILIST
10800 ESB1: JRST .+NACS+1(T)
10850 POP P,A+4
10900 POP P,A+3
10950 POP P,A+2
11000 POP P,A+1
11050 POPAJ: POP P,A
11100 POPJ P,
11150
11200 EFM: HLRZ T,(T)
11250 CALLF 1,(T)
11300 JRST EVAL
11350 PAGE
11400
11450 APPLY: MOVEI TT,AP2
11500 CAME T,[-3]
11550 JRST PDLARG
11600 MOVEM T,APFNG1#
11650 PUSHJ P,ALIST
11700 MOVE T,APFNG1
11750 JSP TT,PDLARG
11800 PUSH P,[UNBIND]
11850 AP2: PUSH P,A
11900 MOVEI T,0
11950 AP3: JUMPE B,IAPPLY ;all args pushed; b has arg list
12000 HLRZ C,(B)
12050 PUSH P,C ;push arg
12100 HRRZ B,(B)
12150 SOJA T,AP3
12200
12250 IAP4: JUMPGE D,TOOFEW ;special case for fexprs
12300 AOJN R,TOOFEW
12350 PUSH P,B
12400 MOVE A,SP
12450 PUSHJ P,FIX1A
12500 EXCH A,(P)
12550 MOVE B,A
12600 MOVNI R,2
12650 SOJA T,IAP5
12700
12750 FUNCT: PUSH P,A
12800 MOVE A,SP
12850 PUSHJ P,FIX1A
12900 POP P,B
12950 HLRZ B,(B)
13000 PUSHJ P,XCONS
13050 MOVEI B,FUNARG(S)
13100 JRST XCONS
13150 PAGE
13200 APFNG: SOS T
13250 MOVEM T,APFNG1
13300 JSP TT,PDLARG ;get args and funarg list
13350 HRRZ A,(A)
13400 HRRZ D,(A) ;a-list pointer
13450 HLRZ A,(A) ;function
13500 HRLZ R,APFNG1 ;no. of args
13550 PUSH P,[UNBIND]
13600 JSP TT,ARGP1 ;replace args and fn name
13650 PUSH P,D ;a-list pointer
13700 PUSHJ P,ALIST ;set up spec pdl
13750 POP P,D
13800 AOS T,APFNG1
13850
13900 ;falls through
13950 PAGE
14000 ;falls in
14050
14100 IAPPLY: MOVE C,T ;state of world at entrance
14150 ADDI C,(P) ;t has - number of args on pdl
14200 ILP1A: HRRZ B,(C) ;next pdl slot has function- poss fun name in lh
14250 CAILE B,INUMIN
14300 JRST UNDTAC
14350 HLRZ A,(B)
14400 CAIN A,-1
14450 JRST IAP1 ;fn is atomic
14500 CAIN A,LAMBDA(S)
14550 JRST IAPLMB
14600 CAIN A,FUNARG(S)
14650 JRST APFNG
14700 CAIN A,LABEL(S)
14750 JRST APLBL
14800 PUSH P,T
14850 MOVE A,B
14900 PUSHJ P,EVAL
14950 POP P,T
15000 MOVE C,T
15050 ADDI C,(P)
15100 ILP1B: MOVEM A,(C)
15150 JRST ILP1A
15200
15250 IAPXPR: HLRZ A,(B)
15300 JRST ILP1B
15350 IAP1: HRRZ B,(B)
15400 JUMPE B,IAP2
15450 HLRZ TT,(B)
15500 HRRZ B,(B)
15550 CAIN TT,EXPR(S)
15600 JRST IAPXPR
15650 CAIN TT,LSUBR(S)
15700 JRST IAP6
15750 CAIE TT,SUBR(S)
15800 JRST IAP1
15850 HLRZ B,(B)
15900 MOVEM B,(C)
15950 JRST ESB1
16000 PAGE
16050 IAPLMB: HRRZ B,(B)
16100 HLRZ TT,(B)
16150 MOVEM SP,SPSV
16200 HRRZ B,(B)
16250 HLRZ D,(TT)
16300 CAIN D,-1
16350 JUMPN TT, IAP3
16400 MOVE R,T
16450 IPLMB1: JUMPE T,IPLMB2 ;no more args
16500 JUMPE TT,TOMANY ;too many args supplied
16550 IAP5: HLRZ A,(TT)
16600 MOVEI AR1,1(T)
16650 ADD AR1,P
16700 HLLZ D,(AR1)
16750 HRLM A,(AR1)
16800 HRRZ TT,(TT)
16850 AOJA T,IPLMB1
16900 PAGE
16950
17000
17050 IPLMB2: JUMPN TT,IAP4 ;too few args supplied
17100 JUMPE R,IAP69
17150 IPLMB4: POP P,AR1
17200 HLRZ A,AR1
17250 AOJG R,IPLMB3
17300 PUSHJ P,BIND
17350 JRST IPLMB4
17400 IPLMB3: SKIPE BACTRF
17450 JRST APBK1
17500 APBK2: MOVEI A,NIL ;$$SETUP FOR IMPLIED PROG
17550 PUSH SP,SPSV
17600 MOVE T,B ;$$SETUP FOR IMPLIED PROG
17650 PUSHJ P,COND2+1 ;$$INSTEAD OF EVAL
17700 JRST UNBIND
17750
17800 IAP69: POP P,(P)
17850 MOVEI A,NIL ;$$SETUP FOR IMPLIED PROG
17900 MOVE T,B ;$$
17950 JRST COND2+1 ;$$INSTEAD OF EVAL
18000
18050 APBK1: HRRI AR1,CPOPJ
18100 TLNE AR1,-1
18150 PUSH P,AR1
18200 JRST APBK2
18250 IAP6: MOVEI TT,CPOPJ
18300 MOVEM TT,(C)
18350 HLRZ B,(B)
18400 JRST (B)
18450
18500 APLBL: MOVEM SP,SPSV
18550 HRRZ B,(B)
18600 HLRZ A,(B)
18650 HRRZ B,(B)
18700 HLRZ AR1,(B)
18750 MOVEM AR1,(C)
18800 PUSHJ P,BIND
18850 MOVEI A,APLBL1
18900 EXCH A,-1(C)
18950 EXCH A,LBLAD#
19000 HRLI A,LBLAD
19050 PUSH SP,A
19100 PUSH SP,SPSV
19150 JRST IAPPLY
19200 APLBL1: PUSH P,LBLAD
19250 JRST SPECSTR
19300
19350 IAP2: HRRZ A,(C)
19400 MOVEI B,VALUE(S)
19450 PUSHJ P,GET
19500 JUMPE A,UNDTAC
19550 HRRZ A,(A)
19600 HRRZ B,(C) ;$$GET ORIGINAL FN NAME
19650 CAME A,B ;$$IF THE VALUE IS THE SAME THEN WE HAVE A LOOP
19700 CAIN A,UNBOUND(S)
19750 JRST UNDTAC
19800 JRST ILP1B
19850
19900 IAP3: MOVNI AR1,-INUM0(T) ;lexpr call
19950 MOVE A,TT
20000 PUSHJ P,BIND
20050 PUSH P,%ARG
20100 SUBI C,INUM0
20150 HRRM C,%ARG
20200 PUSH SP,SPSV
20250 MOVEI A,NIL ;$$ MORE FOR IMPLIED PROG
20300 MOVE T,B ;$$
20350 PUSHJ P,COND2+1 ;$$ INSTEAD OF EVAL
20400 HRRZ T,%ARG
20450 POP P,%ARG
20500 SUBI T,1-INUM0(P)
20550 HRLI T,-1(T)
20600 ADD P,T
20650 JRST UNBIND
20700
20750 ARG: HRRZ A,@%ARG
20800 POPJ P,
20850
20900 REMOTE<%ARG: XWD A,0>
20950 SETARG: HRRZM B,@%ARG
21000 JRST PROG2
21050 PAGE
21100 BIND: JUMPE A,BNDERR ;$$CAN'T REBIND NIL
21150 CAIN A,TRUTH(S) ;$$SHOULDN'T REBIND T
21200 JRST BNDERR ;$$
21250 PUSH P,B
21300 HRRZM A,BIND3#
21350 BIND2:
21400 MOVEI B,VALUE(S) ;bind atom in a to value in ar1,save
21450 PUSHJ P,GET ;old binding on s pdl
21500 JUMPE A,BIND1 ;add value cell
21550 PUSH SP,(A)
21600 HRLM A,(SP)
21650
21700 HRRM AR1,(A) ;$$THIS WAS HHRZM AR1,(A) WHICH CLOBBERED ATOM POINTER IN MY SYSTEM
21750 POPBJ: POP P,B
21800 POPJ P,
21850
21900 BIND1:
21950 MOVEI B,UNBOUND(S)
22000
22050 MOVE A,BIND3 ;$$SET UP ATOM POINTER FROM SPECIAL CELL
22100 ;$$THIS WAS MOVEI A,0
22150 PUSHJ P,CONS
22200 HRRZ B,@BIND3
22250 PUSHJ P,CONS
22300 MOVEI B,VALUE(S)
22350 PUSHJ P,XCONS
22400 HRRM A,@BIND3
22450 MOVE A,BIND3
22500 JRST BIND2
22550
22600 UBD: CAMG SP,B
22650 POPJ P,
22700
22750
22800 HLRZ TT,(SP) ;$$SKIP OVER EVAL BLIPS ETC.
22850 JUMPE TT,.+2 ;$$IF EQUAL TO 0 IT WAS AN EVAL BLIP
22900 JRST PJUBND
22950 SUB SP,[XWD 2,2] ;$$DECREMENT SPDL
23000 JRST UBD ;$$GO BACK AND CHECK
23050
23100 PJUBND: PUSHJ P,UNBIND
23150 JRST UBD
23200
23250 UNBIND:
23300 SPECSTR: MOVE TT,(SP)
23350 CAMN SP,SC2 ;$$CHECK TO AVOID OVERSHOOT
23400 POPJ P, ;$$
23450
23500 SUB SP,[XWD 1,1]
23550 JUMPGE TT,UNBIND ;syncronize stack
23600 UNBND1: CAMN SP,TT
23650 POPJ P,
23700 POP SP,T
23750
23800
23850 CAIN T,(T) ;$$CHECK TO SKIP OVER NEW ITEMS PUT ON SPDL
23900 ;$$ALL SUCH ITEMS HAVE 0 LEFT HAND SIDES
23950 JRST PROGUB ;$$THIS IS AN EVAL BLIP - CHECK IF A PROG
24000
24050 MOVSS T
24100
24150 HLRM T,(T) ;$$CHANGED FROM HLRZM T,(T) TO PROTECT NEW ATOM POINTER
24200
24250 JRST UNBND1
24300
24350
24400 PROGUB: HLRZ T,(T) ;$$CHECK FOR A PROG
24450 CAIE T,PROGAT+1(S) ;$$CHECK IF IT IS A PROG
24500 JRST PROGU1 ;$$NOT A PROG, SKIP IT AND GO ON
24550 MOVE T,(SP) ;$$GET THE RPDL POINTER FOR PROG INTO T
24600 ADDI T,2 ;$$INCREMENT TO GET TO WHERE PA3,PA4 SAVED
24650 POP T,PA4 ;$$RESTORE PA4
24700 POP T,PA3 ;$$AND PA3 FROM WHERE THEY WERE SAVED
24750 PROGU1: POP SP,T ;$$ POP RPDL POINTER
24800 JRST UNBND1 ;$$AND GO ON WITH THE UNBINDING
24850
24900
24950
25000 SPECBIND: MOVE TT,SP
25050 SPEC1: LDB R,[POINT 13,(T),ACFLD]
25100 CAILE R,17
25150 JRST SPECX
25200 SKIPE R
25250 MOVE R,(R)
25300 HLL R,@(T) ;$$AGAIN SAVE THE POOR LITTLE ATOM POINTER
25350 EXCH R,@(T)
25400 HRLI R,@(T)
25450 PUSH SP,R
25500 AOJA T,SPEC1
25550 SPECX: PUSH SP,TT
25600 JRST (T)
25650
25700 ;random special case compiler run time routines
25750
25800 %AMAKE: PUSH P,A ;make alist for fsubr that requires it
25850 MOVE A,SP
25900 PUSHJ P,FIX1A
25950 MOVE B,A
26000 JRST POPAJ
26050
26100 %UDT: PUSHJ P,PRINT ;error print for undefined computed go tag
26150 STRTIP [SIXBIT /UNDEFINED COMPUTED GO TAG IN !/]
26200 HRRZ R,(P)
26250 PUSHJ P,ERSUB3
26300 JRST ERREND
26350
26400 %LCALL: MOVN A,T ;set up routine for compile lsubr
26450 ADDI A,INUM0
26500 ADDI T,(P)
26550 PUSH P,T
26600 PUSHJ P,(3)
26650 POP P,T
26700 SUBI T,(P)
26750 HRLI T,-1(T)
26800 ADD P,T
26850 POPJ P,
00050 SUBTTL ARRAY SUBROUTINES --- PAGE 14
00100
00150 ARRERR=-1
00200
00250 ARRAY: PUSHJ P,ARRAYS
00300 HRRI AR2A,1(R)
00350 MOVE A,AR2A
00400 PUSH R,[0]
00450 AOBJN A,.-1
00500 ARREND: MOVE A,BPPNR#
00550 MOVEM AR2A,-1(A)
00600 MOVEI A,INUM0+1(R)
00650 MOVEM A,VBPORG(S)
00700 POPJ P,
00750
00800 ARRAYS: PUSH P,A
00850 MOVE A,VBPORG(S)
00900 SUBI A,INUM0
00950 MOVEM A,BPPNR
01000 MOVE A,VBPEND(S)
01050 MOVNI A,-INUM0-2(A)
01100 ADD A,BPPNR ;bporg-bpend+2
01150 HRLM A,BPPNR
01200 POP P,A
01250 HRRZ AR1,(A) ;(cdr l)
01300 HLRZ A,(A) ;(car l)name
01350 HRRZ B,BPPNR
01400 ADDI B,2
01450 MOVEI C,SUBR(S)
01500 PUSHJ P,PUTPROP
01550 HLRZ A,(AR1) ;(cadr l)mode
01600 PUSH P,AR1
01650 PUSHJ P,EVAL ;eval mode
01700 POP P,AR1
01750 MOVEM A,AMODE#
01800 MOVEI C,44
01850 JUMPE A,ARRY1
01900 MOVEI C,-INUM0(A)
01950 CAILE A,INUMIN
02000 JRST ARRY1
02050 MOVEI C,22
02100 HRRZ A,BPPNR
02150 MOVE B,GCMKL
02200 PUSHJ P,CONS
02250 MOVEM A,GCMKL
02300 ARRY1: MOVEM C,BSIZE#
02350 MOVEI A,44
02400 IDIV A,C
02450 MOVEM A,NBYTES#
02500 HRRZ A,(AR1) ;(cddr l)bound pair list
02550 JSP TT,ILIST
02600 AOS R,BPPNR
02650 MOVEI AR1,1 ;ar1 is array size
02700 MOVEI AR2A,0 ;ar2a is cumulative residue
02750 AOJGE T,ARRYS ;single dimension
02800 MOVEI D,A-1
02850 SUB D,T ;d is next ac for array code generation
02900 ARRY2: PUSHJ P,ARRB0
02950 TLC TT,(IMULI)
03000 DPB D,[POINT 4,TT,ACFLD]
03050 PUSH R,TT
03100 CAIN D,A
03150 JRST ARRY3
03200 MOVSI TT,(ADD)
03250 ADDI TT,1(D)
03300 DPB D,[POINT 4,TT,ACFLD]
03350 PUSH R,TT
03400 SOJA D,ARRY2
03450
03500 ARRB0: POP P,TT
03550 EXCH TT,(P)
03600 CAILE TT,INUMIN
03650 JRST ARRB1
03700 HLRZ A,(TT)
03750 HRRZ TT,(TT)
03800 SUBI TT,(A)
03850 ADDI TT,1
03900 JRST ARRB2
03950
04000 ARRB1: MOVEI A,INUM0
04050 SUB TT,A
04100 ARRB2: IMUL A,AR1
04150 IMULB AR1,TT
04200 ADDM A,AR2A
04250 POPJ P,
04300
04350 ARRY3: PUSH R,[ADD A,B]
04400 ARRYS: PUSHJ P,ARRB0
04450 HRRZ TT,BPPNR
04500 MOVEM AR2A,(TT)
04550 HRLI TT,(SUB A,)
04600 PUSH R,TT
04650 PUSH R,[JUMPL A,ARRERR]
04700 MOVE TT,AR1
04750 HRLI TT,(CAIL A,)
04800 PUSH R,TT
04850 PUSH R,[JRST ARRERR]
04900 IDIV AR1,NBYTES ;calc #words in array
04950 SKIPE AR2A ;correct for remainder non-zero
05000 ADDI AR1,1
05050 MOVE TT,NBYTES
05100 SOJE TT,ARRY6
05150 ADDI TT,1
05200 HRLI TT,(IDIVI A,)
05250 PUSH R,TT
05300 MOVN TT,BSIZE
05350 LSH TT,14
05400 HRLI TT,(IMULI B,)
05450 PUSH R,TT
05500 MOVEI TT,44+200
05550 SUB TT,BSIZE
05600 LSH TT,6
05650 ARRY6: ADD TT,BSIZE
05700 LSH TT,6
05750 SKIPE AR2A,AMODE
05800 CAIL AR2A,INUMIN
05850 ADDI TT,40 ;mode not = t
05900 TLC TT,(HRLZI C,)
05950 PUSH R,TT
06000 MOVEI TT,4(R)
06050 HRLI TT,(ADDI C,(A))
06100 PUSH R,TT
06150 PUSH R,[LDB A,C]
06200 HRLZI AR2A,(POPJ P,)
06250 SKIPN TT,AMODE
06300 MOVE AR2A,[JRST FLO1A]
06350 CAIL TT,INUMIN
06400 MOVE AR2A,[JRST FIX1A]
06450 PUSH R,AR2A
06500 MOVS AR2A,AR1
06550 MOVNS AR2A
06600 POPJ P,
06650
06700 PAGE
06750 EXARRAY: PUSH P,A
06800 HLRZ A,(A)
06850 PUSHJ P,GETSYM
06900 JUMPE A,POPAJ
06950 PUSHJ P,NUMVAL
07000 EXCH A,(P)
07050 PUSHJ P,ARRAYS
07100 POP P,A
07150 HRRM A,-2(R)
07200 HRR AR2A,A
07250 JRST ARREND
07300
07350 STORE: PUSH P,A
07400 PUSHJ P,CADR
07450 PUSHJ P,EVAL ;value to store
07500 EXCH A,(P)
07550 HLRZ A,(A)
07600 PUSHJ P,EVAL ;byte pointer returned in c
07650 POP P,A
07700 NSTR: PUSH P,A
07750 TLNE C,40
07800 PUSHJ P,NUMVAL ;numerical array
07850 DPB A,C
07900 POP P,A
07950 POPJ P,
00050 SUBTTL EXAMINE, DEPOSIT , ETC --- PAGE 15
00100
00150 BOOLE: MOVE TT,T
00200 ADDI TT,2(P)
00250 MOVE A,-1(TT)
00300 SUBI A,INUM0
00350 DPB A,[POINT 4,BOOLI,OPFLD-2]
00400 PUSHJ P,BOOLG
00450 MOVE C,A
00500 BOOLL: PUSHJ P,BOOLG
00550 XCT BOOLI
00600 REMOTE<
00650 BOOLI: CLEARB C,A>
00700 JRST BOOLL
00750
00800 BOOLG: CAIL TT,(P)
00850 JRST BOOL1
00900 MOVE A,(TT)
00950 PUSHJ P,NUMVAL
01000 AOJA TT,CPOPJ
01050
01100 BOOL1: HRLI T,-1(T)
01150 ADD P,T
01200 POP P,B
01250 JRST FIX1A
01300
01350 EXAMINE:PUSHJ P,NUMVAL
01400 MOVE A,(A)
01450 JRST FIX1A
01500
01550 DEPOSIT:MOVE C,B
01600 PUSHJ P,NUMVAL
01650 EXCH A,C
01700 PUSHJ P,NUMVAL
01750 MOVEM A,(C)
01800 JRST MAKNUM
01850
01900 LSH: MOVEI C,-INUM0(B)
01950 PUSHJ P,NUMVAL
02000 LSH A,(C)
02050 JRST FIX1A
00050 SUBTTL GARBAGE COLLECTER --- PAGE 16
00100
00150 ;garbage collector
00200
00250 GC: PUSHJ P,AGC
00300 JRST FALSE
00350
00400 AGC: SETOM GCFLG ;SET GCFLAG INCASE OF USER CONTROL-C
00450 MOVEM R,RGC#
00500 GCPK1: PUSH P,PA3
00550 PUSH P,PA4
00600 PUSH P,UBDPTR ;special atom UNBOUND; not on OBLIST
00650 PUSH P,MKNAM3
00700 PUSH P,GCMKL ;i/o channel input lists and arrays
00750 PUSH P,BIND3
00800 PUSH P,INITF
00850 GCPK2: PUSH P,[XWD 0,GCP6] ;this is a return address
00900 JRST GCP4
00950 REMOTE<
01000 GCP4: MOVEI S,X ;pdlac, .=bottom of reg pdl + 1
01050 GCP41: BLT S,X ;save ACs 0 through 10 at bottom of regpdl ;pdlac+n
01100 GCP2: CLEARB 0,X ;gc indicator, init. for bit table zero
01150 MOVE A,C3GC
01200 GCP5: BLT A,X ;zero bit tables, .=top of bit tables
01250 JRST GCRET1>
01300 GCRET1: SKIPN GCGAGV
01350 JRST GCP5A
01400 SKIPN F
01450 STRTIP [SIXBIT /←FREE STG EXHAUSTED←!/]
01500 SKIPN FF
01550 STRTIP [SIXBIT /←FULL WORD SPACE EXHAUSTED←!/]
01600
01650 GCP5A: MOVEI TT,1
01700 MOVEI A,0
01750 CALLI A,STIME ;time
01800 MOVNS A
01850 ADDM A,GCTIM#
01900 MOVE C,GCP3# ;.=bottom of reg pdl
01950 GCP6B: MOVE S,P
02000 HLL C,P
02050 MOVEI B,0
02100 GC1: CAMN C,S
02150 POPJ P,
02200 HRRZ A,(C)
02250 GCPI: CAMGE A,GCP# ;.=bottom of bit tables
02300 REMOTE<
02350 GCPP1:
02400 XXX5:FS>
02450 CAMGE A,GCPP1
02500 JRST GCEND
02550 CAML A,GCP1# ;.=bottom of full word space (fws)
02600 JRST GCMFW
02650 MOVE F,(A)
02700 LSHC A,-5
02750 ROT B,5
02800 MOVE AR1,GCBT(B)
02850 TDOE AR1,@GCBTP2 ;bit tab- (fs←-5), .=magic number for sync
02900 JRST GCEND
02950 MOVEM AR1,@GCBTP1 ;bit tab- (fs←-5)
03000 PUSH P,F
03050 HLRZ A,F
03100 JRST GCPI
03150 REMOTE<
03200 GCBTP1: XWD A,0
03250 GCBTP2: XWD A,0
03300 GCMFWS: XWD A,0>
03350
03400 GCMFW: MOVEI AR1,@GCMFWS ;.=- bottom of fws
03450 IDIVI AR1,44
03500 MOVNS AR2A
03550 LSH AR2A,36
03600 ADD AR2A,C2GC
03650 DPB TT,AR2A
03700 GCEND: CAMN P,S
03750 AOJA C,GC1
03800 POP P,A
03850 HRRZS A
03900 JRST GCPI
03950 REMOTE<
04000 GCMKL: XWD 0,[XWD [XWD -NIOCH,CHTAB+FSTCH],0]
04050 C2GC: XWD 430100+AR1,X ;.=bottom of fws bit table
04100 C3GC: 0> ;(bottom bit table)bottom bit table+1
04150 GCBT: XWD 400000,0
04200 ZZ==1B1
04250 XLIST
04300 REPEAT ↑D31,<ZZ
04350 ZZ==ZZ/2>
04400 LIST
04450 GCP6: HRRZ R,SC2
04500 GCP6C: CAIL R,(SP) ;mark sp
04550 JRST GCP6A
04600 PUSH P,(R)
04650 HRRZ C,P
04700 PUSHJ P,GCP6B
04750 SUB P,[XWD 1,1]
04800 AOJA R,GCP6C
04850
04900 GCP6A: HRRZ R,GCMKL ;mark arrays
04950 GCP6D: JUMPE R,GCSWP
05000 HLRZ A,(R)
05050 MOVE D,(A)
05100 GCP6E: PUSH P,(D)
05150 HRRZ C,P
05200 PUSH P,(D)
05250 MOVSS (P)
05300 PUSHJ P,GCP6B
05350 SUB P,[XWD 2,2]
05400 AOBJN D,GCP6E
05450 HRRZ R,(R)
05500 JRST GCP6D
05550
05600 GFSWPP:
05650 PHASE 0
05700 GFSP1==.
05750 JUMPL S,.+3
05800 HRRZM F,(R)
05850 HRRZ F,R
05900 ROT S,1
05950 AOBJN R,.-4
06000 MOVE S,(D)
06050 HRLI R,-40
06100 AOBJN D,GFSP1
06150
06200 LPROG==.
06250 JRST GFSPR
06300
06350 DEPHASE
06400 ;garbage collector sweep
06450
06500 GCSWP: MOVSI R,GFSWPP
06550 BLT R,LPROG
06600 MOVEI F,NIL ;will become movei f,-1
06650 MOVE D,C3GCS
06700 JRST XXX3
06750 REMOTE<
06800 XXX3: MOVEI R,FS ;$$ANOTHER FOOLIST REMNANT
06850 GCBTL1: HRLI R,X ;-(32-<fs&37>
06900 MOVE S,(D)
06950 GCBTL2: ROT S,X ;fs&37
07000 AOBJN D,GFSP1
07050 JRST GFSPR>
07100 GFSPR: MOVE A,C1GCS
07150 MOVE B,C2GCS
07200 PUSHJ P,GCS0
07250 SKIPN GCGAGV
07300 JRST GCSPI1
07350 MOVE B,F
07400 PUSHJ P,GCPNT
07450 STRTIP [SIXBIT / FREE STG,!/]
07500 MOVE B,FF
07550 PUSHJ P,GCPNT
07600 STRTIP [SIXBIT / FULL WORDS AVAILABLE←!/]
07650 GCSPI1: HRLZ S,GCSP1# ;bottom of reg pdl+1
07700 BLT S,NACS+3 ;reload ac's
07750 SUB P,[XWD GCPK2-GCPK1,GCPK2-GCPK1] ;restore p
07800 AOSN GCFLG ;CHECK FLAG FOR PENDING INTERRUPT
07850 JRST GCEXIT ;NO- SO NORMAL EXIT
07900 POP P,JOBOPC ;INTERRUPT WILL CONTINUE FROM THE GC RETURN
07950 PUSH P,GCFLG ;GC WILL RETURN TO THE INTERRUPT POINT
08000 SETZM GCFLG ;CLEAR GCFLG
08050 GCEXIT: JUMPE F,[ERR2 [SIXBIT /NO FREE STG LEFT!/]]
08100 JUMPE FF,[ERR2 [SIXBIT /NO FW STG LEFT!/]]
08150 MOVE R,RGC
08200 MOVEI A,0
08250 CALLI A,STIME ;time
08300 ADDM A,GCTIM
08350 MOVE S,ATMOV ;$$RESTORE ATOM OFFSET RELOCATOR (FOOLIST)
08400 ;$$HOPEFULLY S IS USED ONLY BY GC AND ATOM RELOCATION
08450
08500 POPJ P,
08550
08600 GCS0: MOVEI FF,0
08650 GCS1: ILDB C,B
08700 JUMPN C,GCS2
08750 HRRZM FF,(A)
08800 HRRZ FF,A
08850 GCS2: AOBJN A,GCS1
08900 POPJ P,
08950
09000 REMOTE<
09050 C1GCS: 0 ;(- length of fws) bottom of fws
09100 C2GCS: XWD 100,0 ;.=bottom of fws bit table
09150 C3GCS: 0 ;-n wds in bt,,bt
09200 >
09250 GCGAG: EXCH A,GCGAGV#
09300 POPJ P,
09350
09400 GCTIME: MOVE A,GCTIM
09450 JRST FIX1A
09500
09550 TIME: MOVEI A,0
09600 CALLI A,STIME
09650 JRST FIX1A
09700
09750 SPEAK: MOVE A,CONSVAL#
09800 JRST FIX1A
09850
09900 GCPNT: MOVEI R,TTYO
09950 MOVEI A,0
10000 JUMPE B,PRINL1
10050 HRRZ B,(B)
10100 AOJA A,.-2
10150
10200 GCING: OUTSTR [ASCIZ /
10250 GARBAGE COLLECTING
10300 /]
10350 POP P,GCFLG ;CAN'T INTERRUPT GC, QUEUE UP THE REQUEST
10400 JRST @JOBOPC
00050 SUBTTL GETSYM --- PAGE 17
00100
00150 R50MAK: PUSHJ P,PNAMUK
00200 PUSH C,[0]
00250 HRLI C,700
00300 HRRI C,(SP)
00350 MOVEI B,0
00400 MK3: ILDB A,C
00450 LDB A,R50FLD
00500 CAMGE B,[50*50*50*50*50]
00550 SKIPN A
00600 POPJ P,
00650 IMULI B,50
00700 ADD B,A
00750 JRST MK3
00800
00850 GETSYM: PUSHJ P,R50MAK
00900 TLO B,040000 ;04 for globals
00950 MOVE C,JOBSYM
01000 MK7: CAMN B,(C)
01050 JRST MK10 ;found
01100 AOBJP C,.+2
01150 AOBJN C,MK7
01200 TLC B,140000 ;10 for locals
01250 TLNE B,100000
01300 JRST MK7-1
01350 JRST FALSE
01400
01450 MK10: MOVE A,1(C) ;value
01500 JRST FIX1A
01550
01600 PUTSYM: PUSH P,B
01650 PUSHJ P,R50MAK
01700 MOVE A,B
01750 TLO A,040000 ;make global
01800 SKIPL JOBSYM
01850 AOS JOBSYM ;increment initial symbol table pointer
01900 MOVN B,[XWD 2,2]
01950 ADDB B,JOBSYM
02000 MOVEM A,(B) ;name
02050 POP P,1(B) ;value
02100 JRST FALSE
02150
02200 PATCH: BLOCK 20
02250
00050 SUBTTL ALVINE AND LOADER INTERFACES --- PAGE 18
00100
00150 ;interface to alvine
00200
00250 IFN ALVINE,<
00300 ED: MOVE 10,EDA
00350 JRST (10)
00400 PUSH P,A
00450 HRRZ A,CORUSE
00500 HRRM A,LST
00550 AOS A
00600 HRRM A,EDA#
00650
00700
00750 HRRM A,ED1 ;$$SAVE REENTRY TO EDITOR
00800 AOS ED1# ;$$
00850
00900 MOVSI A,(SIXBIT /ED/)
00950 SETZ D, ;THAT RELOCATION AGAIN - SEE BELOW
01000 PUSHJ P,SYSINI
01050 HRLM A,LST
01100 MOVNS A
01150 PUSHJ P,MORCOR
01200 PUSHJ P,SYSINP+1
01250 POP P,A
01300 JRST ED
01350 GRINDEF:PUSH P,A
01400 PUSHJ P,ED
01450 POP P,A
01500 JRST 2(10)>
01550
01600 EXCISE:
01650 IFN ALVINE<
01700 MOVEI A,ED+2
01750 HRRM A,EDA>
01800 MOVE A,JRELO
01850 SETZM LDFLG# ;initial loader symbol table flag
01900 CALLI A,CORE
01950 JRST .+1
02000 JSP R,IOBRST
02050 JRST TRUE
02100
02150 PAGE
02200 ;THIS IS THE NEW IMPROVED VERSION OF SPRINT
02250
02300 ; 0(P) = A
02350 ; -1(P) = B
02400 ; -2(P) = C
02450 ; -3(P) = M
02500 ; -4(P) = N
02550 ; -5(P) = X
02600
02650
02700 SPRINT: SUBI B,INUM0
02750 SPRNT2: PUSH P,A
02800 PUSH P,B
02850 SETZM M#
02900 SETZM CSW#
02950 MOVEM P,STP#
03000 MOVEI B,0
03050 PUSHJ P,DEPTH
03100 SKIPN B,M
03150 JRST .+6
03200 MOVE A,LINL
03250 SUB A,B
03300 SUB A,B
03350 IDIV A,B
03400 CAILE A,14
03450 MOVEI A,14
03500 MOVEM A,CUT#
03550 MOVE A,0(P)
03600 IDIV A,LINL
03650 CAIG B,0
03700 ADD B,LINL
03750 MOVEM B,0(P)
03800 MOVEI C,0
03850 JRST .+3
03900
03950 ISPRIN: PUSH P,A
04000 PUSH P,B
04050 PUSH P,C
04100 PUSH P,[0]
04150 PUSH P,[0]
04200 PUSH P,[0]
04250 MOVE A,B
04300 SUB B,LINL
04350 JUMPLE B,.+3
04400 MOVE A,B
04450 MOVEM A,-4(P)
04500 PUSHJ P,POS
04550 MOVE A,-5(P)
04600 PUSHJ P,PATOM
04650 JUMPE A,.+4
04700 SPRN1: MOVE A,-5(P)
04750 PUSHJ P,PRIN1
04800 JRST SPRN22
04850 MOVE B,LINL
04900 SUB B,-4(P)
04950 ADDI B,1
05000 MOVEM B,0(P)
05050 SUB B,-3(P)
05100 MOVE A,-5(P)
05150 PUSHJ P,FLATLE
05200 JUMPN A,SPRN1
05250 MOVEI A,50
05300 PUSHJ P,TYO
05350 AOS -4(P)
05400 SOS 0(P)
05450 HRRZ A,@-5(P)
05500 PUSHJ P,PATOM
05550 JUMPN A,SPRN13
05600 HLRZ A,@-5(P)
05650 CAIN A,LAMBDA(S)
05700 JRST LAM
05750 CAIN A,PROGAT+1(S)
05800 JRST PRG
05850 PUSHJ P,PATOM
05900 JUMPE A,SPRN3
05950 HLRZ A,@-5(P)
06000 PUSHJ P,PRIN1
06050 MOVE A,0(P)
06100 SUB A,CHCT
06150 MOVEM A,-1(P)
06200 CAIG A,24
06250 JRST SPRN4
06300 JRST SPRN12+4
06350 SPRN3: MOVE B,0(P)
06400 CAILE B,20
06450 MOVEI B,20
06500 HLRZ A,@-5(P)
06550 PUSHJ P,FLATLE
06600 JUMPE A,SPRN12
06650 MOVEM A,-1(P)
06700 SPRN4: HRRZ A,@-5(P)
06750 MOVEM A,-2(P)
06800 HRRZ A,0(A)
06850 PUSHJ P,PATOM
06900 JUMPN A,SPRN8
06950 MOVE B,-1(P)
07000 CAMG B,CUT
07050 JRST SPRN2
07100 SKIPE CSW
07150 JRST SPRN8
07200 MOVE A,0(P)
07250 SUB A,B
07300 SUBI A,1
07350 MOVEM A,-1(P)
07400 JRST SPRN5
07450 SPRN2: HLRZ A,@-5(P)
07500 PUSHJ P,PATOM
07550 JUMPN A,.+3
07600 HLRZ A,@-5(P)
07650 PUSHJ P,PRIN1
07700 HRRZ A,@-5(P)
07750 MOVEM A,-5(P)
07800 MOVE A,-4(P)
07850 ADD A,-1(P)
07900 ADDI A,1
07950 MOVEM A,-4(P)
08000 JRST SPRN12
08050 SPRN5: MOVE B,-1(P)
08100 HLRZ A,@-2(P)
08150 PUSHJ P,FLATLE
08200 JUMPE A,SPRN8
08250 HRRZ A,@-2(P)
08300 MOVEM A,-2(P)
08350 HRRZ A,0(A)
08400 PUSHJ P,PATOM
08450 JUMPE A,SPRN5
08500 HRRZ B,@-2(P)
08550 JUMPN B,.+3
08600 MOVE B,-1(P)
08650 SOJA B,SPRN7
08700 HRRZ A,@-2(P)
08750 PUSHJ P,FLATSI
08800 SUBI A,INUM0-4
08850 SUB A,-1(P)
08900 MOVN B,A
08950 SPRN7: SUB B,-3(P)
09000 HLRZ A,@-2(P)
09050 PUSHJ P,FLATLE
09100 JUMPN A,SPRN18
09150 SPRN8: HLRZ A,@-5(P)
09200 PUSHJ P,PATOM
09250 JUMPN A,.+3
09300 SPRN9: HLRZ A,@-5(P)
09350 PUSHJ P,PRIN1
09400 HRRZ A,@-5(P)
09450 MOVEM A,-5(P)
09500 CAMN A,-2(P)
09550 JRST SPRN11
09600 MOVE A,-4(P)
09650 PUSHJ P,POS
09700 JRST SPRN9
09750 SPRN11: HRRZ A,@-5(P)
09800 PUSHJ P,PATOM
09850 JUMPN A,SPRN13
09900 SPRN12: MOVEI C,0
09950 MOVE B,-4(P)
10000 HLRZ A,@-5(P)
10050 PUSHJ P,ISPRIN
10100 HRRZ A,@-5(P)
10150 MOVEM A,-5(P)
10200 JRST SPRN11
10250 SPRN13: HRRZ A,@-5(P)
10300 JUMPE A,.+4
10350 PUSHJ P,FLATSI
10400 SUBI A,INUM0-3
10450 ADDM A,-3(P)
10500 AOS -3(P)
10550 MOVE C,-3(P)
10600 MOVE B,-4(P)
10650 HLRZ A,@-5(P)
10700 PUSHJ P,ISPRIN
10750 SPRN16: HRRZ A,@-5(P)
10800 JUMPE A,SPRN17
10850 MOVEI A,40
10900 PUSHJ P,TYO
10950 MOVEI A,56
11000 PUSHJ P,TYO
11050 MOVEI A,40
11100 PUSHJ P,TYO
11150 HRRZ A,@-5(P)
11200 PUSHJ P,PRIN1
11250 SPRN17: MOVEI A,51
11300 PUSHJ P,TYO
11350 JRST SPRN22
11400 SPRN18: HLRZ A,@-5(P)
11450 PUSHJ P,PATOM
11500 JUMPN A,.+3
11550 HLRZ A,@-5(P)
11600 PUSHJ P,PRIN1
11650 MOVEI A,40
11700 PUSHJ P,TYO
11750 HRRZ A,@-5(P)
11800 MOVEM A,-5(P)
11850 MOVE A,LINL
11900 SUB A,CHCT
11950 ADDI A,1
12000 MOVEM A,-4(P)
12050 HRRZ A,@-5(P)
12100 PUSHJ P,PATOM
12150 JUMPN A,SPRN21
12200 SPRN19: HLRZ A,@-5(P)
12250 PUSHJ P,PRIN1
12300 HRRZ A,@-5(P)
12350 MOVEM A,-5(P)
12400 HRRZ A,0(A)
12450 PUSHJ P,PATOM
12500 JUMPN A,.+4
12550 MOVE A,-4(P)
12600 PUSHJ P,POS
12650 JRST SPRN19
12700 MOVE A,-4(P)
12750 PUSHJ P,POS
12800 SPRN21: HLRZ A,@-5(P)
12850 PUSHJ P,PRIN1
12900 JRST SPRN16
12950 LAM: PUSHJ P,PRIN1
13000 HRRZ A,@-5(P)
13050 MOVEM A,-5(P)
13100 MOVE B,-4(P)
13150 MOVEM B,-1(P)
13200 HLRZ A,0(A)
13250 PUSHJ P,PATOM
13300 MOVEI B,6
13350 CAIE A,NIL
13400 ADDI B,1
13450 ADDM B,-4(P)
13500 HRRZ A,@-5(P)
13550 PUSHJ P,PATOM
13600 JUMPN A,SPRN13
13650 MOVEI C,0
13700 MOVE B,-4(P)
13750 HLRZ A,@-5(P)
13800 PUSHJ P,ISPRIN
13850 MOVE B,-1(P)
13900 MOVEM B,-4(P)
13950 JRST SPRN12+4
14000 PRG: PUSHJ P,PRIN1
14050 HRRZ A,@-5(P)
14100 MOVEM A,-5(P)
14150 MOVE A,-4(P)
14200 MOVEM A,-1(P)
14250 MOVEI A,5
14300 ADDM A,-4(P)
14350 HRRZ A,@-5(P)
14400 PUSHJ P,PATOM
14450 JUMPN A,SPRN13
14500 MOVEI C,0
14550 MOVE B,-4(P)
14600 HLRZ A,@-5(P)
14650 PUSHJ P,ISPRIN
14700 MOVE A,0(P)
14750 SUBI A,5
14800 MOVEM A,-2(P)
14850 PRG1: HRRZ A,@-5(P)
14900 MOVEM A,-5(P)
14950 HRRZ A,0(A)
15000 PUSHJ P,PATOM
15050 JUMPN A,PRG3
15100 HLRZ A,@-5(P)
15150 PUSHJ P,PATOM
15200 JUMPE A,PRG2
15250 MOVE A,-1(P)
15300 PUSHJ P,POS
15350 HLRZ A,@-5(P)
15400 PUSHJ P,PRIN1
15450 JRST PRG1
15500 PRG2: MOVE A,CHCT
15550 CAMG A,-2(P)
15600 PUSHJ P,TERPRI
15650 MOVEI C,0
15700 MOVE B,-4(P)
15750 HLRZ A,@-5(P)
15800 PUSHJ P,ISPRIN
15850 JRST PRG1
15900 PRG3: HLRZ A,@-5(P)
15950 PUSHJ P,PATOM
16000 JUMPE A,SPRN13
16050 MOVE B,-1(P)
16100 MOVEM B,-4(P)
16150 JRST SPRN13
16200 SPRN22: MOVEI A,NIL
16250 SUB P,[XWD 6,6]
16300 POPJ P,
16350
16400 POS: PUSH P,A
16450 PUSH P,[0]
16500 MOVE A,LINL
16550 SUB A,CHCT
16600 ADDI A,1
16650 PUSH P,A
16700 CAMN A,-2(P)
16750 JRST POS4
16800 CAMG A,-2(P)
16850 JRST .+4
16900 PUSHJ P,TERPRI
16950 MOVEI A,1
17000 MOVEM A,0(P)
17050 SUBI A,1
17100 LSH A,-3
17150 ADDI A,1
17200 LSH A,3
17250 ADDI A,1
17300 MOVEM A,-1(P)
17350 CAMLE A,-2(P)
17400 JRST POS3
17450 POS2: MOVEI A,11
17500 PUSHJ P,TYO
17550 MOVE A,-1(P)
17600 MOVEM A,0(P)
17650 ADDI A,10
17700 JRST POS2-3
17750 POS3: AOS A,0(P)
17800 CAMLE A,-2(P)
17850 JRST POS4
17900 MOVEI A,40
17950 PUSHJ P,TYO
18000 JRST POS3
18050 POS4: SUB P,[XWD 3,3]
18100 POPJ P,
18150
18200 FLATLE: JUMPLE B,ABORT+1
18250 SETZM M
18300 MOVEM B,N#
18350 MOVEM P,STP
18400 SCAN: PUSH P,A
18450 PUSHJ P,PATOM
18500 JUMPN A,EXIT1-6
18550 NA: AOS A,M
18600 CAMLE A,N
18650 JRST ABORT
18700 HLRZ A,@0(P)
18750 PUSHJ P,SCAN
18800 HRRZ A,@0(P)
18850 MOVEM A,0(P)
18900 JUMPN A,.+3
18950 AOS A,M
19000 JRST EXIT1-2
19050 MOVE A,0(P)
19100 PUSHJ P,PATOM
19150 JUMPE A,NA
19200 MOVEI A,4
19250 ADDB A,M
19300 CAMLE A,N
19350 JRST ABORT
19400 MOVE A,0(P)
19450 PUSHJ P,FLATSI
19500 SUBI A,INUM0
19550 ADDB A,M
19600 CAMLE A,N
19650 JRST ABORT
19700 EXIT1: SUB P,[XWD 1,1]
19750 POPJ P,
19800 ABORT: MOVE P,STP
19850 MOVEI A,NIL
19900 POPJ P,
19950
20000 DEPTH: PUSH P,A
20050 PUSH P,B
20100 PUSHJ P,PATOM
20150 JUMPN A,D2
20200 AOS A,0(P)
20250 CAMLE A,LINL
20300 JRST OUT+1
20350 CAMLE A,M
20400 MOVEM A,M
20450 MOVE A,-1(P)
20500 PUSH P,A
20550 PUSH P,[0]
20600 D1: HLRZ A,@-3(P)
20650 MOVE B,-2(P)
20700 PUSHJ P,DEPTH
20750 HRRZ A,@-3(P)
20800 MOVEM A,-3(P)
20850 MOVE B,-1(P)
20900 SETCMB C,0(P)
20950 JUMPN C,.+3
21000 HRRZ B,0(B)
21050 MOVEM B,-1(P)
21100 CAMN A,B
21150 JRST OUT
21200 PUSHJ P,PATOM
21250 JUMPE A,D1
21300 SUB P,[XWD 2,2]
21350 D2: SUB P,[XWD 2,2]
21400 POPJ P,
21450 OUT: SETOM CSW
21500 MOVE P,STP
21550 JRST @1(P)
21600 ;
21650 ;
21700 ;(TAB X) TABS TO POSITION X DOING A (TERPRI) IF NECESSARY
21750 ;
21800 .TAB: PUSHJ P,NUMVAL
21850 PUSHJ P,POS ;LET POS IN SPRINT DO THE WORK
21900 JRST FALSE
21950 PAGE
22000 ; lisp loader interface
22050 ; REG. D IS USED SINCE VARIABLES ARE MOVE WHEN LISP IS REENTRANT
22100 LOAD: AOS B,CORUSE
22150 MOVEM B,OLDCU#
22200 MOVEM A,LDPAR#
22250 JUMPE A,LOAD2
22300 MOVE B,VBPORG(S)
22350 SUBI B,INUM0
22400 LOAD2: MOVEM B,RVAL# ;final destination of loaded code
22450 MOVSI A,(SIXBIT /LOD/)
22500 SETZ D,
22550 PUSHJ P,SYSINI
22600 SUBI A,150 ;extra room for locations 0 to 137 and slop
22650 PUSH P,A
22700 MOVNS A ;length(loader)
22750 HRRZM A,LODSIZ#
22800 PUSHJ P,MORCOR ;expand core for loader
22850 MOVEM A,LOWLSP# ;location of blt'ed low lisp
22900 MOVN B,(P) ;length(loader)
22950 ADD B,A
23000 MOVEM B,HVAL# ;temporary destination of loaded code
23050 HRLI A,0
23100 MOVE D,A ;THIS IS THE RELOCATION, THE LOADER WILL SAVE IT
23150 BLT A,(B) ;blt up low lisp
23200 HLL A,NAME+3(D) ;-length(loader)
23250 HRRI A,137-1
23300 PUSHJ P,SYSINP
23350 SKIPE LDFLG(D)
23400 JRST LOAD3
23450 SETOM LDFLG(D)
23500 MOVSI A,(SIXBIT /SYM/)
23550 PUSHJ P,SYSINI
23600 MOVNS A ;length symbols
23650 PUSHJ P,MORCOR ;expand core for symbols
23700 SKIPGE B,JOBSYM
23750 SOS B ;if no symbol table, use original jobsym
23800 HLRZ A,NAME+3(D) ;-length(symbols)
23850 ADDB A,B
23900 HLL A,NAME+3(D) ;symbol table iowd
23950 PUSHJ P,SYSINP
24000 HRRM B,JOBSYM
24050 HLLZ A,NAME+3(D)
24100 ADDM A,JOBSYM
24150 SKIPA
24200 LOAD3: SOS JOBSYM ;want jobsym to point one below 1st symbol
24250 MOVE 3,HVAL(D) ;h
24300 MOVE 5,RVAL(D) ;r
24350 MOVE 2,3
24400 SUB 2,5 ;x=h-r
24450 HRLI 5,12 ;(w)
24500 HRLI 2,11 ;(v)
24550 SETZB 1,4
24600 JSP 0,140 ;call the loader
24650 MOVEM 5,RLAST#(D) ;last location loaded(in final area)
24700 MOVE T,OLDCU(D)
24750 MOVE A,JOBSYM
24800 MOVEM A,JOBSYM(T)
24850 MOVE A,JOBREL
24900 MOVEM A,JOBREL(T) ;update jobrel
24950 HRLZ 0,LOWLSP(D)
25000 SOS LODSIZ(D)
25050 AOBJN 0,.+1
25100 BLT 0,@LODSIZ(D) ;blt down low lisp
25150 MOVE 0,@LOWLSP ;EVERY THING IS FIXED, DON'T NEED REG. D ANYMORE
25200 MOVE B,RLAST
25250 MOVE A,RVAL
25300 HRL A,HVAL
25350 SKIPE LDPAR
25400 JRST BINLD
25450 MOVE C,RLAST ;new coruse
25500 LDRET2: BLT A,(B) ;blt down loaded code
25550 HRRZM C,CORUSE ;top of code loaded
25600 MOVEI B,1
25650 ANDCAM B,JOBSYM
25700 SUB C,JOBSYM ;length of free core
25750 ORCMI C,776000
25800 AOJGE C,START ;no contraction
25850 ADD C,JOBREL ;new top of core
25900 MOVE B,C
25950 PUSHJ P,MOVDWN
26000 HRLM C,JOBSA
26050 CALLI C,CORE ;contract core
26100 JRST .+1
26150 JRST START
26200
26250 BINLD: MOVEI C,INUM0(B)
26300 CAML C,VBPEND(S)
26350 JRST [ SETOM BPSFLG ;bps exceeded
26400 JRST START]
26450 MOVEM C,VBPORG(S) ;updat bporg
26500 SOS C,OLDCU ;old top of core
26550 JRST LDRET2
26600
26650 SYSINI: MOVEM A,NAME+1(D)
26700 IFN SYSPRG,< MOVE A,[XWD SYSPRG,SYSPN]
26750 MOVEM A,NAME+3(D)>
26800 IFE SYSPRG,< SETZM NAME+3(D)>
26850 INIT 17
26900 SYSDEV
26950 0
27000 JRST AIN.4+1
27050 LOOKUP NAME(D)
27100 JRST AIN.7+1
27150 MOVE A,[IOWD 1,NAME+3] ;KLUDGE BECAUSE OF REG. D
27200 ADD A,D
27250 MOVEM A,INLOW(D)
27300 INPUT INLOW(D) ;INPUT SIZE OF FILE
27350 REMOTE<
27400 INLOW: IOWD 1,NAME+3
27450 0>
27500 HLRO A,NAME+3(D)
27550 POPJ P,
27600
27650 REMOTE<
27700 NAME: SIXBIT/ILISP/
27750 0
27800 0
27850 0>
27900
27950 SYSINP: MOVEM A,LST(D)
28000 INPUT LST(D)
28050 STATZ 740000
28100 ERR1 AIN.8
28150 RELEASE
28200 POPJ P,
28250
28300 REMOTE<
28350 LST: 0
28400 0>
28450 PAGE
28500 MOVDWN: HLRZ A,JOBSYM
28550 JUMPE A,MOVS1
28600 ADDI A,1(B)
28650 HRL A,JOBSYM
28700 HRRM A,JOBSYM
28750 BLT A,(B) ;downward blt
28800 POPJ P,
28850
28900 MOVSYM: MOVE B,JOBREL
28950 HRLM B,JOBSA
29000 HLRE A,JOBSYM
29050 JUMPE A,MOVS1
29100 ADDI B,1(A) ;new bottom of symbol table
29150 MOVNI A,1(A)
29200 ADD A,JOBSYM ;last loc of old symbol table
29250 HRRM B,JOBSYM
29300 PUSH P,C
29350 MOVE B,JOBREL ;last loc of new symbol table
29400 MOVE C,(A) ;simulated upward blt
29450 MOVEM C,(B)
29500 SUBI B,1
29550 ADDI A,-1 ;lf+1,rt-1
29600 JUMPL A,.-4
29650 POP P,C
29700 POPJ P,
29750
29800 MOVS1: HRRZM B,JOBSYM
29850 POPJ P,
29900
29950 ;enter with size needed in a
30000 ;exit with pointer in a to core
30050
30100 MORCOR: PUSH P,B
30150 HRRZ B,JOBSYM
30200 SUB B,CORUSE(D)
30250 SUBM A,B
30300 JUMPL B,EXPND2
30350 ADD B,JOBREL ;new core size
30400 CALLI B,CORE ;expand core
30450 ERR1 [SIXBIT /CANT EXPAND CORE !/]
30500 PUSH P,A
30550 PUSHJ P,MOVSYM
30600 POP P,A
30650 EXPND2: MOVE B,CORUSE(D)
30700 ADDM A,CORUSE(D)
30750 MOVE A,B
30800 POP P,B
30850 POPJ P,
30900 PAGE
30950 SUBTTL HIGH SEGMENT FUNCTIONS
31000
31050 REMOTE<VHGHORG:BHORG>
31100 HGHCOR: JUMPE A,NOWRT ;EXPAND CORE AND SET WRITE STATUS
31150 PUSHJ P,NUMVAL
31200 JUMPLE A,FALSE
31250 CLEARB C,WRTSTS
31300 CALLI C,SETUWP
31350 UWPERR: ERR1 [SIXBIT /CAN'T CHANGE HIGH SEG. WRITE PROTECT!/]
31400 MOVE B,VHGHORG
31450 ADD B,A
31500 HRRZ C,JOBHRL
31550 CAMG B,C
31600 JRST TRUE
31650 IFE STANSW,< HRLZ A,B
31700 CALLI A,CORE >
31750 IFN STANSW,< HRRZ A,B
31800 CALLI A,400015>
31850 ERR1 [SIXBIT /CAN'T EXPAND HIGH SEGMENT!/]
31900 JRST TRUE
31950 NOWRT: MOVEI A,1
32000 MOVEM A,WRTSTS
32050 CALLI A,SETUWP
32100 JRST UWPERR
32150 JRST TRUE
32200
32250 HGHORG: SKIPE A ;SET HIGH ORG. TO A AND RETURN OLD ORG.
32300 PUSHJ P,NUMVAL
32350 PUSH P,A
32400 MOVE A,VHGHORG
32450 MOVEI B,FIXNUM(S)
32500 PUSHJ P,MAKNUM
32550 POP P,B
32600 SKIPE B
32650 MOVEM B,VHGHORG
32700 POPJ P,
32750
32800 HGHEND: HRRZ A,JOBHRL ;GET VALUE OF END OF HIGH SEG.
32850 MOVEI B,FIXNUM(S)
32900 JRST MAKNUM
32950
33000 ;SETS THE GETSEG INFO. SO USER CAN HAVE OWN HIGH SEG.
33050 SETSYS: MOVE T,A ;MOVE ARGUMENT FOR UIOSUB
33100 PUSHJ P,IOSUB ;BREAKS DOWN THE SPECIFICATION
33150 CAME A,[SYSNAM] ; *** MJC
33200 ; We're not allowing him to name his segment the same as ours, *** MJC
33250 ; since that causes problems for ATTSEG, so test for it. *** MJC
33300 JRST GUDSEG ; *** MJC
33350 MOVE B,[SYSDEV] ; But if he's a system hacker *** MJC
33400 CAME B,DEV ; then we let him get away *** MJC
33450 JRST BADSEG ; with it. *** MJC
33500 GUDSEG: MOVEM A,HGHDAT+1 ;SAVE THE FILE NAME
33550 MOVE A,DEV ;GET THE DEVICE AND SAVE IT
33600 MOVEM A,HGHDAT
33650 MOVEM A,INTDAT+1 ; Save it for OPEN, too. *** MJC
33700 MOVE A,PPN ;GET THE PPN AND SAVE IT
33750 MOVEM A,SGPPPN ; *** MJC
33800 MOVEM A,HGHDAT+4
33850 SKIPN A,EXT ; Get extension and save it. *** MJC
33900 MOVE A,[SIXBIT/SEG/] ; No ext -- use SEG instead. *** MJC
33950 MOVEM A,HGHDAT+2 ; Move ext into OPEN stuff. *** MJC
34000 OPEN 0,INTDAT ; Open for dump output. *** MJC
34050 JRST BADSEG ; Couldn't open? *** MJC
34100 ENTER 0,HGHDAT+1 ; Hookup to file. *** MJC
34150 JRST BADSEG ; Couldn't do it? *** MJC
34200 CALLI A,400022 ; Find size of high segment. *** MJC
34250 MOVNS A ; Construct dump mode cmd wd. *** MJC
34300 HRLM A,HGHDAT+4 ; I.e. -length to left half *** MJC
34350 MOVEI A,SHRST-1 ; and <start>-1 to rt half. *** MJC
34400 HRRM A,HGHDAT+4 ; *** MJC
34450 OUTPUT 0,HGHDAT+4 ; *** MJC
34500 CLOSE 0,2 ; Leave no traces *** MJC
34550 JRST FALSE ;RETURN NIL
34600 BADSEG: ERR1 [SIXBIT/ILLEGAL NAME FOR SEGMENT!/] ; *** MJC
34650 JRST FALSE ; *** MJC
34700
34750 REMOTE<WRTSTS: 1>
34800 PAGE
34850 SUBTTL REALLOC CODE --- PAGE 19
34900
34950 STRT:
35000 INALLC: HRRZ A,JOBREL ;SEE IF CORE WAS EXPANDED
35050 CAMN A,JRELO# ;OR NOT
35100 JRST OUTALC ;NO EXPANSION - DON'T REALLOCATE
35150 CAMG A,JRELO# ;CHECK TO SEE IF IT GOT SMALLER!
35200 JRST 4,0 ;YES - BITCH
35250 MOVEM A,JRELO# ;SAVE NEW CORE BOUND
35300 HRLM A,JOBSA
35350 IFN ALVINE,<
35400 MOVEI F,ED+2 ;INDICATE THAT ED WAS OVERWRITTEN
35450 HRRM F,EDA ;SO ED AND GRINDEF WILL BE READ IN IF NEEDED>
35500 INAGN: SETZM NOALIN# ;SET UP TO ASK FOR ALLOCATION
35550 OUTSTR [ASCIZ /
35600 ALLOC? (Y OR N) /] ;ASK USER IF HE WISHES TO SET UP
35650 INCHRW C ;THE ALLOCATION INCREMENTS
35700 CAIGE C,"O"
35750 SETOM NOALIN# ;SET FLAG SO NO INPUT IS DONE LATER
35800 SETFWS: MOVE A,SFWS# ;SAVE OLD SIZE OF FWS
35850 MOVEM A,OSFWS#
35900
35950 SKIPN NOALIN ;SKIP QUESTIONS IF AUTOMATIC
36000 OUTSTR [ASCIZ /
36050 FULL WORD SP. = /]
36100 JSP R,ALLNUM
36150 JUMPN A,.+3
36200 SKIPE INITFW#
36250 ADDI A,440 ;INITIAL ALLOCATION FOR FWS
36300
36350 ADDM A,SFWS# ;ADD EITHER USER INCREMENT OR 0 TO SFWS
36400
36450 MOVE A,FSO# ;SAVE OLD FS ORIGIN
36500 MOVEM A,OFSO# ;FOR RELOCATION
36550
36600
36650 SKIPN NOALIN ;SKIP IF USER DONE
36700 OUTSTR [ASCIZ /
36750 BIN. PROG. SP. = /]
36800 JSP R,ALLNUM
36850 ADDM A,SBPS#
36900 MOVEM A,FSMOVE# ;THE INCREMENT TO SBPS IS THE AMOUNT BY
36950 ADDM A,FSO# ;THE FREE SPACE IS MOVED - UPDATE ORIGIN
37000
37050
37100
37150 SKIPN NOALIN ;SKIPIF USER DONE
37200 OUTSTR [ASCIZ /
37250 REG. PDL. = /]
37300 JSP R,ALLNUM
37350 JUMPN A,.+3
37400 SKIPE INITFW# ;CHECK IF INITIAL ALLOCATION
37450 ADDI A,1000
37500 ADDM A,SRPDL#
37550 MOVN AR1,A ;SAVE IN CASE OF OVERFLOW
37600
37650
37700 SKIPN NOALIN ;SKIP IF USER DONE
37750 OUTSTR [ASCIZ /
37800 SPEC. PDL. = /]
37850 JSP R,ALLNUM
37900 JUMPN A,.+3
37950 SKIPE INITFW# ;CHECK FOR INITIAL ALLOCATION
38000 ADDI A,1000
38050 ADDM A,SSPDL#
38100 MOVN AR2A,A ;SAVE IN CASE OF OVERFLOW
38150 IFN HASH,<
38200 SKIPN INITFW
38250 SETOM NOALIN
38300 SKIPN NOALIN
38350 OUTSTR [ASCIZ /
38400 HASH = /]
38450 JSP R,ALLNUM
38500 CAIG A,BCKETS
38550 JRST OCR
38600 HRRM A,INT1
38650 MOVNS A
38700 HRRM A,RH4
38750 SETOM HASHFG>
38800 OCR: OUTSTR [ASCIZ /
38850 /]
38900 MOVE A,JRELO# ;COMPUTE SIZE OF AVAILABLE CORE
38950 SUBI A,FS ;SO THAT EXTRA CORE CAN BE DISTRIBUTED
39000
39050 SUB A,SBPS ;TAKE OFF CORE ALLOCATED FOR BPS
39100 SUB A,SFS# ;TAKE OFF CORE IN PREVIOUS FS
39150 SUB A,SBT# ;AND ASSOCIATED BIT TABLE
39200 SUB A,SFWS ;TAKE OFF CORE NOW ALLOCATED TO FWS
39250 SUB A,SRPDL ;TAKE OFF CORE NOW ALLOCATED TO RPDL
39300 SUB A,SSPDL ;TAKE OFF CORE NOW ALLOCATED TO SPDL
39350
39400 MOVE F,SFWS ;ESTIMATE SIZE NEEDED FOR BTF
39450 IDIVI F,44
39500 ADDI F,1
39550 SUB A,F ;AND TAKE IT OFF TOTAL
39600 MOVEM F,SBTF# ;ALSO SAVE TO RESTORE LATER
39650 JUMPGE A,ALOK ;MAKE SURE NO OVERFLOW
39700 OUTSTR [ASCIZ /ALLOCATIONS ARE TOO LARGE
39750 /] ; IF SO THEN RETRY
39800 MOVE A,OSFWS
39850 MOVEM A,SFWS ;RESTORE SIZE OF FWS
39900 MOVN A,FSMOVE
39950 ADDM A,SBPS ;RESET SIZE OF BPS
40000 ADDM A,FSO ;AND FS ORGIN
40050 ADDM AR1,SRPDL ;RESET STACKS
40100 ADDM AR2A,SSPDL
40150 JRST INAGN
40200
40250 ALOK: MOVE B,A ;NOW CAN ALLOCATE EXCESS CORE
40300 ACHLOC: ASH B,-4 ;1/16 TO FWS
40350 ADDM B,SFWS
40400 SUB A,B ;TAKE IT OFF REMAINING CORE
40450 SKIPE INITFW
40500 SETZ B,
40550 ASH B,-4 ;1/64 TO PDLS
40600 ADDM B,SSPDL
40650 SUB A,B
40700 ADDM B,SRPDL
40750 SUB A,B ;AND TAKE IT OFF REMAINING CORE
40800
40850 MOVE T,SFWS ;CALCULATE ACTUAL SIZE OF BTF
40900 IDIVI T,44
40950 ADDI T,1
41000 ADD A,SBTF ;REMOVE ESTIMATED LOSS FOR BTF
41050 MOVEM T,SBTF
41100 SUB A,T ;AND TAKE OFF ACTUAL LOSS TO BTF
41150
41200 ADD A,SFS ;ADD BACK ON SPACE FROM OLD FS
41250 ADD A,SBT ;AND ASSOCIATED BT
41300 ;GIVING NEW SPACE AVAILABLE FOR
41350 ;FS AND BT
41400 MOVE TT,A
41450 IDIVI TT,41 ;SBS = SFS/32. = (SBS + SFS)/33.
41500
41550 ADDI TT,1
41600 MOVEM TT,SBT
41650
41700 SUB A,TT ;TAKE OFF SBT FROM REMAINING CORE
41750 MOVEM A,SFS ;GIVING AVAILABLE SFS
41800
41850
41900 ;SET UP REGISTERS FOR GC ETC. SETUP
41950
42000 MOVE A,SFWS ;A ← SFWS
42050 MOVEI B,FS
42100 ADD B,SFS
42150 ADD B,SBPS ;B ← NFWSO (ORIGIN OF NEW FULL WORD SPACE)
42200 MOVE C,SRPDL ;C ← SRPDL
42250 MOVE F,OSFWS ;F ← OLD SIZE OF FWS
42300
42350
42400
42450
42500 HRRM B,GCP1 ;GCP1 ← NFWSO
42550 MOVN SP,B ;-NEW BOTTOM OF FWS
42600
42650 HRRM SP,GCMFWS
42700 HRLZM A,C1GCS
42750 MOVNS C1GCS ;-NEW LENGTH OF FWS
42800 HRRM B,C1GCS ;HAVE FWS POINTER AND COUNT FOR SWEEP
42850
42900 ADD B,A ;NEW FIRST WORD OF BT (FS BIT TABLE)
42950
43000
43050 MOVE SP,FSO ;SP ← NEW ORIGIN OF FS
43100
43150 LSH SP,-5
43200 SUBM B,SP ;NUMBER USED TO FIND BIT TABLE WORD
43250 HRRM SP,GCBTP1 ;FROM FS WORD ADDRESS
43300 HRRM SP,GCBTP2
43350
43400 HRLM B,C3GC ;BOTTOM OF BIT TABLES
43450 HRRM B,GCP2
43500 HRRM B,GCP ;(ALSO UPPER BOUND ON FWS AND FS)
43550
43600 MOVNI SP,-2(TT) ;-SIZE OF BT (TT = SBT)
43650 HRLM SP,C3GCS ;IOWD FOR BIT TABLE SWEEP
43700 HRRM B,C3GCS
43750 MOVE SP,FSO
43800 ANDI SP,37 ;MASK OUT ALL BU LAST FIVE BITS
43850 HRRM SP,GCBTL2 ;MAGIC NUMBER TO POSITION
43900 SUBI SP,40
43950 HRRM SP,GCBTL1
44000
44050 ADDI B,1 ;B ← B + 1
44100 HRRM B,C3GC ;BOTTOM OF FS BIT TABLE + 1
44150 ADDI B,-2(TT) ;GET BOTTOM OF BTF - 1, POINTER IS INCREMENTED
44200 HRRM B,C2GCS ;BEFORE USE
44250
44300 ADDI B,1 ;B ← B + 1
44350 HRRM B,C2GC ;BOTTOM OF FWS BIT TABLE + 1
44400 ADDI B,-1(T) ;SINCE T IS NOW SIZE OF BTF, NOT SBTF-1
44450
44500 HRRM B,GCP5 ;TOP OF BIT TABLES
44550 ADDI B,1 ;BOTTOM OF REG PDL
44600
44650 HRRZ A,RHX2 ;GET OBLIST POINTER
44700 ADD A,FSMOVE ;INCREMENT TO
44750 ;ACCOUNT FOR MOVE OF FS
44800 MOVEM A,(B)
44850 HRRM B,GCP3 ;ROOM FOR ACS DURING GC
44900 ADDI B,1 ;B ← B + 1
44950 HRRM B,GCSP1
45000 HRRM B,GCP4 ;ROOM FOR ACS
45050 ADDI B,10 ;B ← B + 10
45100 HRRM B,GCP41 ;TOP OF AC AREA
45150 ADDI B,1 ;B ← B + 1
45200 HRRM B,C2 ;SET UP RPDL POINTER
45250 MOVNI A,-20(C) ;A ← - (C -20) = -(SRPDL - 20)
45300 HRLM A,C2 ;THIS IS THE ACTUAL SIZE OF RPDL
45350 ;TAKING INTO ACCOUNT THE AC AREA
45400
45450 HRRZ A,JRELO# ;TOP OF CORE - FOR SPDL PTR
45500
45550 MOVN B,SSPDL
45600 ADD A,B
45650 HRL A,B
45700
45750 MOVEM A,SC2# ;SET UP SPDL POINTER (I HOPE)
45800 MOVN A,A ;CREATE OFFSET FOR STACK POINTERS
45850 ADDI A,INUM0
45900 HRRZM A,SPNM#
45950 SETZM INITFW ;TURN OFF INITIAL ALLOCATION FLAG
46000
46050
46100
46150
46200 ;RELOCATE THE FULL WORD SPACE
46250 ;GCP1 HOLDS POINTER TO ORIGIN OF NEW FWS
46300 ;FWSO# HOLDS POINTER TO ORIGIN OF OLD FWS
46350 ;AND F HOLDS SIZE OF OLD FWS (AMOUNT TO BE MOVED)
46400
46450 MOVSI B,F
46500 HRR B,GCP1
46550 MOVE C,FWSO#
46600 HRRZI AR2A,-1(C) ;TAKE THE OPPORTUNITY TO GET ADDRESS
46650 ;OF END OF OLD FS (USED LATER)
46700 HRLI C,F
46750 MOVE A,@C ;GET WORD FROM END OF OLD FWS
46800 MOVEM A,@B ;AND MOVE TO END OF NEW FWS
46850 SOJGE F,.-2 ;F COUNTS DOWN WORDS IN OLDFWS
46900 ;END OF FWS RELOCATION
46950
47000 MOVE FF,FSMOVE ;GET FAST ACCESS TO RELOCATE SIZE FOR FS
47050 HRRZ F,AR2A
47100 ADD F,FF ;AND FIND WHERE TO PUT WORDS FROM
47150 ;END OF OLD FS IN NEW FS
47200
47250
47300
47350 HRRZ AR1,GCP1 ;COMPUTE FWS RELOCATION CONSTANT
47400 SUB AR1,FWSO
47450
47500
47550
47600 ;RELOCATE FS - ALSO RELOCATE ALL
47650 ;POINTERS TO FS AND TO FWS
47700
47750 REL1: HLRZ A,(AR2A) ;GET CAR POINTER OF OLD FS WORD
47800 JSP R,REL4
47850 HRLM A,(F) ;MOVE CAR TO NEW POSITION
47900 HRRZ A,(AR2A) ;GET CDR PTR
47950 JSP R,REL4 ;CHECK FOR FS RELOCATE
48000 HRRM A,(F)
48050 SUBI F,1 ;F ← F -1
48100 CAMLE AR2A,OFSO ;CHECK TO SEE IF DONE
48150 SOJA AR2A,REL1 ;NO - GO LOOP
48200 HRRZ A,GCMKL ;RELOCATE ARRAYS
48250 JSP R,REL4
48300 HRRZ D,A
48350 MOVEM D,GCMKL
48400 REL5: HLRZ AR2A,(D)
48450 MOVE AR2A,(AR2A)
48500 REL6: HLRZ A,(AR2A)
48550 JSP R,REL4
48600 HRLM A,(AR2A)
48650 HRRZ A,(AR2A)
48700 JSP R,REL4
48750 HRRM A,(AR2A)
48800 AOBJN AR2A,REL6
48850 HRRZ D,(D)
48900 JUMPN D,REL5
48950 SETZM BIND3 ;JUST IN CASE
49000 SKIPE INITF ;DON'T FORGET THE INITFN
49050 ADDM FF,INITF
49100 SKIPE NOUUOF ;RELOCATE FLAGS
49150 ADDM FF,NOUUOF
49200 SKIPE BACTRF
49250 ADDM FF,BACTRF
49300 SKIPE GCGAGV
49350 ADDM FF,GCGAGV
49400 SKIPE RSTSW
49450 ADDM FF,RSTSW
49500 JRST RELFOO
49550
49600 REL4: CAMGE A,EFWSO ;SEE IF BEYOND END OF FWS
49650 CAMGE A,OFSO ;OK - SEE IF MAYBE IN FS
49700 JRST (R)
49750 CAMGE A,FWSO ;SEE IF IN FWS
49800 JRST .+3
49850 ADD A,AR1 ;RELOCATE FWS POINTER
49900 JRST (R)
49950 ADD A,FF ;RELOCATE FS POINTER
50000 JRST (R)
50050
50100
50150
50200
50250
50300 RELFOO: MOVE S,SBPS ;S IS THE RELOCATOR FOR MOST MACRO
50350 MOVEM S,ATMOV ;REFERENCES TO ATOMS AND FS
50400 MOVE A,FSMOVE ;NOW IS THE TIME FOR ALL GOOD MEN TO
50450 ADDM A,VBPEND(S) ;SET BPEND
50500 ADDM A,XXX1 ;AND SOMEOTHER CRAP
50550 ADDM A,XXX2
50600 ADDM A,XXX3
50650 ADDM A,XXX4
50700 ADDM A,XXX5
50750 MOVE A,GCP1
50800 HRRZM A,FWSO
50850 MOVE A,C3GCS
50900 HRRZM A,EFWSO#
50950 OUTALC: CLEARB F,DDTIFG
51000 JSP R,IOBRST
51050 JRST START
51100
51150
51200
51250
51300
00050
00100 ;SUBROUTINE FOR NUMBER INPUT
00150
00200
00250 ALLNUM: MOVEI A,0
00300 SKIPE NOALIN#
00350 JRST (R)
00400 INCHRW C
00450 CAIN C,RUBOUT
00500 JRST [OUTSTR [ASCIZ /XXX /]
00550 JRST ALLNUM]
00600 CAIL C,"0"
00650 CAILE C,"9"
00700 JRST BANGCK
00750 ASH A,3
00800 ADDI A,-"0"(C)
00850 JRST ALLNUM+3
00900
00950 BANGCK: CAIE C,LF
01000 JRST (R)
01050 SETOM NOALIN#
01100 JRST (R)
01150
01200 ;RETURNS 0 IF NOALIN # 0
01250 ;SETS NOALIN # 0 IF IT GETS A LINE FEED INPUT
01300
01350
01400
01450 PAGE
01500
01550
01600
01650
01700 IFN HASH,<
01750 REHASH:
01800 MOVEI A,BFWS(S)
01850 PUSH P,A
01900 HRRM A,RHX2
01950 HRRM A,RHX5
02000 MOVS B,RH4#
02050 ADD B,S ;$$PUT IN ATOM MOVE OFFSET IN B, SINCE CAN'T
02100 ;$$DOUBLE INDEX - THIS REMOVES THE FOO PROBLEM
02150 ;$$IN THE NEXT THREE FOO'S
02200
02250 HRRZI A,BFWS+1(B)
02300 MOVEM A,BFWS(B)
02350 AOBJN B,.-2
02400 SETZM BFWS(B)
02450 MOVSI AR2A,-BCKETS
02500 HRR AR2A,S ;$$PUT IN ATOM MOVE OFFSET IN AR2A TO AVOID
02550 ;$$DOUBLE INDEXING WITH S IN REMOVING FOO
02600 ;$$PROBLEM
02650 RH1:
02700 HLRZ C,OBTBL(AR2A)
02750 RH3: JUMPE C,RH2
02800 HLRZ A,(C)
02850 PUSH P,C
02900 PUSH P,AR2A
02950 PUSHJ P,INTERN
03000 POP P,AR2A
03050 POP P,C
03100 HRRZ C,(C)
03150 JRST RH3
03200 RH2: AOBJN AR2A,RH1
03250 SETZM HASHFG
03300 POP P,A
03350 HRRM A,@GCP3
03400 MOVEM A,OBLIST(S)
03450 JRST START>
03500
03550 PAGE
03600 SUBTTL NEW FUNCTIONS TO MAKE USE OF MODIFIED SPECIAL PDL FOR ERRORS
03650
03700 ;$$ROUTINE TO GET POINTER TO SPDL AND MAKE IT INTO AN INUM
03750 SPDLPT: HRRZ A,SP ;$$CREATE A POINTER TO THE CURRENT TOP OF STACK
03800 ADD A,SPNM
03850 POPJ P, ;$$
03900
03950
04000 ;$$ROUTINE TO GET LEFT HAND SIDE OF SPDL ITEM INDICATED BY AN INUM FROM SPDLPT
04050 SPDLFT: SUB A,SPNM ;$$CONVERT TO ADDRESS
04100 HLRE A,(A) ;$$GET LEFT HAND ITEM
04150 JUMPL A,TRUE ;$$IF IT IS NEGATIVE IT CAME FROM A STACK
04200 ;$$POINTER AND WE RETURN T INSTEAD
04250 HRRZI A,(A) ;$$CLEAR OUT LEFT HAND OF AC
04300 POPJ P, ;$$RETURN - RETURNS NIL FOR LHS = 0
04350
04400 ;$$ROUTINE TO GIVE RIGHT HAND SIDE OF SPDL ENTRY SPECIFIED BY AN INUM FROM SPDLPT
04450 SPDLRT: SUB A,SPNM ;$$CONVERT TO AN ADDRESS
04500 HRRZ A,(A) ;$$ALL RHS ITEMS ARE LEGAL, NO NEED FOR CHECK
04550 POPJ P, ;$$
04600
04650 ;$$ROUTINE TO GET POINTER TO NEXT EVAL BLIP ON SPDL
04700 NEXTEV: SUB A,SPNM ;$$GET POINTER INSTEAD OF INUM
04750 HRRZ T,SC2 ;$$GET POINTER TO BOTTOM OF SPDL
04800
04850 SPDNLP: CAMG A,T ;$$CHECK IF HIT THE BOTTOM OF SPDL
04900 JRST FALSE ;$$RETURN NIL IF NO MORE INTERESTING WORDS
04950 HLL A,(A) ;$$TEST FOR WORD WITH 0 LHS
05000 TLZE A,-1 ;$$
05050 SOJA A,SPDNLP ;$$NOT AN INTERESTING WORD, LOOK AGAIN
05100 ADD A,SPNM ;$$FOUND AN INTERESTING WORD, CHANGE POINTER TO INUM
05150 POPJ P, ;$$
05200
05250
05300 ;$$ROUTINE TO EVALUATE A VARIABLE IN AN EARLIER CONTEXT
05350 ;$$ MORE EFFICIENT THAN EVAL WITH ALIST
05400 EVALV: MOVE C,A ;$$ MOVE AROUND FOR ATOM CHECK
05450 PUSHJ P,ATOM ;$$
05500 EXCH A,C ;$$
05550 SUB B,SPNM ;$$
05600 EVALV1: CAIN B,(SP) ;$$CHECK FOR END OF SPDL
05650 JRST GETV ;$$VARIABLE NOT REBOUND - GET CURRENT VALUE
05700 SKIPGE ,(B) ;$$CHECK TO AVOID SPDL POINTERS ON STACK
05750 AOJA B,EVALV1 ;$$
05800 HLRZ T,(B) ;$$T←CAR(B)
05850 SKIPE C ;$$
05900 HLRZ T,(T) ;$$GET CAR OF SPECIAL CELL - ATOM POINTER
05950 CAIE T,(A) ;$$COMPARE WITH ATOM TO BE EVALUATED
06000 AOJA B,EVALV1 ;$$NOT IT, LOOK SOME MORE
06050 HRRZ A,(B) ;$$GET VALUE FROM SPDL
06100 POPJ P, ;$$
06150
06200 GETV: JUMPE C,GETV1
06250 MOVEI B,VALUE(S) ;$$ATOM NOT REBOUND, VALUE THEN IS
06300 PUSHJ P,GET ;$$
06350 JUMPE A,UNBOND ;$$NOT BOUND AT ALL, GIVE UNBVAR MESSAGE
06400 GETV1: HRRZ A,(A) ;$$GET CDR OF SPECIAL CELL
06450 POPJ P, ;$$
06500
06550 UNBOND: HRRZI A,UNBOUND(S) ;$$RETURN ATOM UNBOUND
06600 POPJ P, ;$$
06650
06700 ;$$ROUTINE TO CLEAR SPECIAL PDL TO POSITION SPECIFIED BY INUM
06750 CLRSPD: MOVEI B,-2-INUM0(A) ;$$ -2 TO GET OVER EVAL BLIP
06800 HLRZ TT,SC2# ;$$GET REAL SPD POINTER WITH A LHS
06850 ADD TT,B ;$$FIND OUT HOW MANY WORDS ARE USED
06900 ADD B,SC2 ;$$
06950 HRL B,TT ;$$SET UP SPD POINTER
07000 JRST UBD ;$$UBD DOES ALL THE WORK
07050
07100 ;$$ROUTINE TO RETURN FROM SPECIAL PDL CONTEXT, SPECIFIED BY AN
07150 ;$$EVAL BLIP, WITH A GIVEN VALUE
07200 OUTVAL: PUSHJ P,NEXTEV ;$$FORCE TO AN EVAL BLIP
07250 JUMPE A,FALSE ;$$ NO EVAL BLIP, RETURN NIL
07300 HRLZI C,(POPJ P,) ;$$ SET TYPE OF RETURN
07350 JRST SPRE1 ;$$ FINISH UP IN SPREDO
07400
07450
07500 ;$$ROUTINE TO RE-EVALUATE EXPRESSION FROM AN EVAL BLIP AND GO ON FROM
07550 ;$$ THAT CONTEXT (NOT A USER CALLABLE FUNCTION)
07600 REVAL1: HRRZ P,1(SP) ;$$ RPDL POINTER IS UP ONE
07650 HRRZ T,C2# ;$$
07700 HLRZ TT,C2# ;$$
07750 ADD TT,P ;$$
07800 SUB TT,T ;$$
07850 HRL P,TT ;$$
07900 DOSET: MOVE D,ERRTN ;$$ POP ERRSETS, LOAD CURRENT ERRSET
07950 SKIPE D ;$$DONE IF EMPTY
08000 CAMG D,P ;$$ COMPARE TO CURRENT RPDL
08050 XCT C ;$$ DONE, DO A STRANGE EXIT
08100 SUB D,[XWD 1,1] ;$$ GO DOWN A WORD
08150 POP D,ERRSW ;$$
08200 POP D,ERRTN ;$$
08250 SUB D,[XWD 2,2] ;$$ SKIP PROG JUNK
08300 JRST DOSET ;$$ TRY AGAIN
08350
08400
08450
08500 ;$$ROUTINE TO CLEAR SPD TO A GIVEN POINT AND REDO FROM THERE
08550 ;$$ A CONTAINS AN SPD INUM POINTER, FORCE IT TO BE EVAL BLIP POINTER
08600
08650 SPREDO: PUSHJ P,NEXTEV ;$$FORCE TO EVAL BLIP POINTER
08700 JUMPE A,CPOPJ ;$$RETURN NIL IF NO EVAL BLIP
08750 MOVE B,A ;$$GET THE EXPRESSION
08800 SUB B,SPNM
08850 HRRZ B,(B)
08900 MOVE C,[JRST EVAL] ;$$SET RETURN
08950 SPRE1: PUSH P,B ;$$SAVE SPDL POINTER
09000 PUSHJ P,CLRSPD ;$$CLEAR OUT SPD - INCLUDES RESTORING PROGS
09050 POP P,A ;$$
09100 JRST REVAL1
09150
09200 ;$$ SPREVAL - SIMILAR TO OUTVAL BUT EVALUATES THE GIVEN VALUE
09250 ;$$AS OF THE SPECIFIED CONTEXT, EQUIVALENT TO:
09300 ;$$ (PROG2 (RPLACD (NUMVAL (SETQ A (NEXTEV A))) B) (SPREDO B))
09350 ;
09400 SPREVAL:PUSHJ P,NEXTEV ;$$FORCE TO AN EVAL-BLIP
09450 JUMPE A,CPOPJ ;$$RETURN NIL IF NO EVAL-BLIP
09500 JRST SPRE1-1 ;$$LET SPREDO FINISH UP
09550
09600
09650 ;$$COMPUTES A LISP POINTER TO A STACK ENTRY
09700 STKPTR: SUB A,SPNM
09750 POPJ P,
09800
09850 LALL
09900 PAGE
09950 SUBTTL LOW SETMENT INCLUDING REMOTE CODE
10000 RELOC 0
10050 HERE
10100 VAR
10150 XALL
10200 PAGE
10250 SUBTTL LISP ATOMS AND OBLIST --- PAGE 20
10300 FS:
10350
10400 DEFINE MAKBUC (A,%B)
10450 <DEFINE OBT'A <%B=.>
10500 XWD %B,IFN <<BCKETS-1>-A>,<.+1>
10550 IF1 <%B=0>>
10600
10650 DEFINE ADDOB (A,C,%B)
10700 <OBT'A
10750 DEFINE OBT'A<%B=.>
10800 IF1 <%B=0>
10850 XWD C,%B>
10900
10950 DEFINE PUTOB (A,B)
11000 <ZZ==<ASCII +A+>←<-1>
11050 ZZ==-ZZ/BCKETS*BCKETS+ZZ
11100 ADDOB \ZZ,B>
11150
11200 DEFINE PSTRCT (A)
11250 <ZZ==[ASCII +A+]
11300 LENGTH(ZY,<A>)
11350 ZY==<ZY-1>/5
11400 Q1(ZY,ZZ)
11450 >
11500
11550 DEFINE Q1 (N,Z)<
11600 IFN N,<XWD Z,[Q1(N-1,Z+1)]>
11650 IFE N,<XWD Z,0>>
11700 DEFINE MKAT (A,B,C,D)
11750 <XLIST
11800 IRP A< PUTOB A,.+1
11850 D XWD -1,.+1
11900 XWD B,.+1
11950 XWD C'A,.+1
12000 XWD PNAME,.+1
12050 XWD [PSTRCT(A)],0>
12100 LIST>
12150
12200 DEFINE MKAT1 (A,B,C,D)
12250 <XLIST
12300 IRP C <PUTOB C,.+1
12350 XWD -1,.+1
12400 XWD B,.+1
12450 XWD D'A,.+1
12500 XWD PNAME,.+1
12550 XWD [PSTRCT(C)],0>
12600 LIST>
12650 DEFINE LENGTH (A,B)
12700 <A==0
12750 IRPC B,<A==A+1>>
12800 DEFINE ML1 (A)<IRP A,<
12850 V'A: XWD -1,.+1
12900 XWD FIXNUM,[A]
12950 MKAT A,SYM,V
13000 >>
13050
13100 DEFINE MKSY1 (A,B,%C)<
13150 XLIST
13200 %C: XWD -1,.+1
13250 XWD FIXNUM,[A]
13300 PUTOB B,.+1
13350 XWD -1,.+1
13400 XWD SYM,.+1
13450 XWD %C,.+1
13500 XWD PNAME,.+1
13550 XWD [PSTRCT(B)],0
13600 LIST>
13650
13700 DEFINE ML (A)<
13750 XLIST
13800 IRP A,<PUTOB A,.+1
13850 A: XWD -1,.+1
13900 XWD PNAME,.+1
13950 XWD [PSTRCT(A)],0>
14000 LIST>
14050 DEFINE MK (A)<
14100 XLIST
14150 IRP A,<PUTOB A,.+1
14200 XWD -1,.+1
14250 XWD PNAME,.+1
14300 XWD [PSTRCT(A)],0>
14350 LIST>
14400
14450 OBTBL:
14500 OBLIST: ZZ==0
14550 XLIST
14600 REPEAT BCKETS,<MAKBUC \ZZ
14650 ZZ==ZZ+1>
14700 LIST
14750
14800 PAGE
14850 MKAT<RPLACA,RPLACD,MINUS,TERPRI,READ,CAR,CDR,CAAR>,SUBR
14900 MKAT<CADR,CDAR,CDDR,CAAAR,CAADR,CADAR,CADDR,CDAAR,CDADR,CDDAR,CDDDR>,SUBR
14950 MKAT<CAAAAR,CAAADR,CAADAR,CAADDR,CADAAR,CADADR,CADDAR,CADDDR,CDAAAR>,SUBR
15000 MKAT<CDAADR,CDADAR,CDADDR,CDDAAR,CDDADR,CDDDAR,CDDDDR,MAKNUM,CONS>,SUBR
15050 MKAT<STRINGP,ATOM,PATOM,EQ,PRIN1,PRINT,RETURN,EXPLODE,SASSOC,ASSOC>,SUBR
15100 MKAT<GCGAG,CHRCT,LINELENGTH,NUMBERP,EQUAL,SUBST,GET,INTERN,MEMBER>,SUBR
15150 MKAT<LOAD,MAKNAM,READCH,NOT,NULL,GENSYM,ZEROP,DIVIDE,GCD>,SUBR
15200 MKAT<TIME,FIX,SET,PROG2,LENGTH,READLIST,LAST,ADD1,SUB1>,SUBR
15250 MKAT<GCTIME,REVERSE,SPEAK,GC,GETL,BAKGAG,MEMQ>,SUBR
15300 MKAT<PUTPROP,PRINC,FLATSIZE,ERR,EXAMINE,DEPOSIT,LSH>,SUBR
15350 MKAT<NCONS,XCONS,REMPROP,ARG,SETARG,NOUUO,MINUSP>,SUBR
15400 MKAT<OUTC,INC,DDTIN,INITFN,EXCISE,REMAINDER,ABS>,SUBR
15450 MKAT<PROG1,SPRINT,LITATOM,NTHCHAR>,SUBR
15500 IFN STPGAP,<MAKAT<PGLINE>,SUBR>
15550
15600 MKAT EXPLODEC,SUBR,%
15650 MKAT TAB,SUBR,.
15700 MKAT TYO,SUBR,I
15750 MKAT TYI,SUBR,I
15800 CEVAL=.+1
15850 MKAT1 EVAL,SUBR,*EVAL
15900
15950 ;$$ REDEF. FOR NEW MAP FUNCTIONS
16000 MKAT<MAPCAN,MAPCON,MAPLIST,MAPCAR,MAP,MAPC>,LSUBR
16050 ;$$ GIVE MAPCAN THE DOUBLE NAME MAPCONC
16100 MKAT1 MAPCAN,LSUBR,MAPCONC
16150
16200 PROGAT: MKAT<PROG>,FSUBR
16250
16300 MKAT <PROGN,LIST,COND,SETQ,INPUT,OUTPUT,SETSYS>,FSUBR
16350 IFN ALVINE,<MKAT<GRINDEF>,FSUBR
16400 MKAT<ED>,SUBR>
16450 IFE ALVINE,<MK<GRINDEF>>
16500 MKAT<ERRSET,REMOB,OR,GO,ARRAY,STORE>,FSUBR
16550 MKAT<AND,DEFPROP,CSYM,EXARRAY>,FSUBR
16600 MKAT1 QUOTE,FSUBR,FUNCTION
16650 MKAT1 %CLRBFI,SUBR,CLRBFI
16700 MKAT1 .ERROR,SUBR,ERROR
16750 MKAT1 LINRD,SUBR,LINEREAD
16800 MKAT1 UNBOND,SUBR,UNBOUND
16850 MKAT1 ECHO,SUBR,TTYECHO
16900 MKAT1 FUNCT,FSUBR,*FUNCTION
16950 MKAT <APPEND,NCONC,BOOLE,APPLY>,LSUBR
17000
17050 MKAT EVAL,LSUBR,O
17100 MKAT ASCII,SUBR,A
17150 MKAT QUOTE,FSUBR,,CQUOTE:
17200 MKAT INUM0,SYM
17250
17300 PUTOB T,.+1
17350 TRUTH: XWD -1,.+1
17400 XWD VALUE,.+1
17450 XWD VTRUTH,.+1
17500 XWD PNAME,.+1
17550 XWD [PSTRCT(T)],0
17600 VTRUTH: TRUTH
17650
17700 PUTOB NIL,0
17750 CNIL2: XWD VALUE,.+1
17800 XWD VNIL,.+1
17850 XWD PNAME,.+1
17900 XWD [PSTRCT(NIL)],0
17950 VNIL: NIL
18000 MKSY1 %LCALL,*LCALL
18050 MKSY1 %AMAKE,*AMAKE
18100 MKSY1 %UDT,*UDT
18150 MKSY1 .MAPC,*MAPC
18200 MKSY1 .MAP,*MAP
18250 MKAT1 %NOPOINT,VALUE,*NOPOINT
18300 %NOPOINT: NIL
18350
18400
18450 UNBOUND: XWD -1,.+1
18500 XWD PNAME,.+1
18550 XWD [PSTRCT(UNBOUND)],0
18600 PAGE
18650 MKAT1 EXPN1,SUBR,*EXPAND1
18700 MKAT1 EXPAND,SUBR,*EXPAND
18750 MKAT1 PLUS,SUBR,*PLUS,.
18800 MKAT1 DIF,SUBR,*DIF,.
18850 MKAT1 QUO,SUBR,*QUO,.
18900 MKAT1 TIMES,SUBR,*TIMES,.
18950 MKAT1 APPEND,SUBR,*APPEND,.
19000 MKAT1 RSET,SUBR,*RSET,.
19050 MKAT1 GREAT,SUBR,*GREAT,.
19100 MKAT1 LESS,SUBR,*LESS,.
19150 MKAT1 PUTSYM,SUBR,*PUTSYM
19200 MKAT1 GETSYM,SUBR,*GETSYM
19250
19300 ML1 <SPECBIND,SPECSTR,FIX1A,NSTR>
19350
19400 PUTOB NUMVAL,.+1
19450 XWD -1,.+1
19500 XWD SUBR,.+1
19550 XWD NUMVAL,.+1
19600 XWD SYM,.+3
19650 XWD FIXNUM,[NUMVAL]
19700 XWD -1,.-1
19750 XWD .-1,.+1
19800 XWD PNAME,.+1
19850 XWD [PSTRCT(NUMVAL)],0
19900
19950 MKAT <OBLIST,BASE,IBASE,BPEND,BPORG>,VALUE,V
20000
20050 ;$$ATOMS FOR DEFINITIONS OF FUNCTIONS FOR NEW SPDL PACKAGE
20100
20150 ML ERRORX
20200 MKAT1 INTPRP,SUBR,INITPROMPT
20250 MKAT1 LSPRET,FSUBR,**TOP**
20300 MKAT<PROMPT,READP,UNTYI,STKPTR,SPREDO,SPREVAL>,SUBR
20350 MKAT<MEMB,NEXTEV>,SUBR
20400 MKAT<SPDLFT,SPDLRT,SPDLPT>,SUBR
20450 MKAT<EVALV,OUTVAL>,SUBR
20500
20550 ;$$ MORE EXTENSIONS INCLUDING READ MACROS
20600 ML READMACRO
20650 MKAT1 %FLATSIZEC,SUBR,FLATSIZEC
20700 MKAT <NEQ,CONSP,CHRVAL,SETCHR,MODCHR,COPY,LEXORDER>,SUBR
20750 MKAT <FREE,FREELIST,SYSCLR,HGHCOR,HGHORG,HGHEND>,SUBR
20800 MKAT1 FALSE,FSUBR,SPECIAL
20850 MKAT1 FALSE,FSUBR,NOCALL
20900 MKAT1 FALSE,FSUBR,DECLARE
20950 MKAT1 FALSE,FSUBR,NILL
21000 MKAT1 APPLY.,SUBR,APPLY#
21050 MKAT1 .MAX,SUBR,*MAX
21100 MKAT1 .MIN,SUBR,*MIN
21150 MKAT1 MEMBR.,SUBR,MEMBER#
21200 MKAT1 MEMB,SUBR,MEMQ#
21250 MKAT1 AND.,FSUBR,AND#
21300 MKAT1 OR.,FSUBR,OR#
21350
21400 ;$$ THE BREAK VARIABLES WHICH TELL ABOUT DEPTH IN THE BREAK PACKAGE
21450 MKAT1 BIOCHN,VALUE,#%IOCHANS%#
21500 MKAT1 BPMPT,VALUE,#%PROMPTS%#
21550 MKAT1 BINDNT,VALUE,#%INDENT
21600 BIOCHN: NIL
21650 BPMPT: NIL
21700 BINDNT: INUM0
21750
21800 VOBLIST: OBLIST
21850 VBASE: 8+INUM0
21900 VIBASE: 8+INUM0
21950
22000 ML <PNAME,FIXNUM,FLONUM,VALUE,LAMBDA,SUBR,FSUBR,EXPR,FEXPR,SYM,∨
22050 $EOF$,LABEL,FUNARG,LSUBR,MACRO>
22100
22150 PUTOB ?,.+1
22200 QST: XWD -1,.+1
22250 XWD PNAME,.+1
22300 XWD [PSTRCT(?)],0
22350
22400 VBPORG: INUM0
22450 VBPEND: INUM0
22500
22550 ;MKAT ACHLOC,SYM
22600 ;DONT KNOW WHATS UP HERE, IF NEEDED CHECK ACHLOC
22650
22700 PAGE
22750 ;
22800 ; ALL THE ATOMS IN THE WHOLE SYSTEM
22850 MK<A,ADD,AFTER,ALIAS,ARGPRINT,ASSOC#,ATM,B,BEFORE,BELOW,BEND1,BF,BI,BIND>
22900 MK<BK,BKE,BKEV,BKEVAL,BKF,BKFNLIST,BKFV,BKPOS,BKPROG,BKSETQ,BKV>
22950 MK<BLOCK,BLOCKED,BO,BORG1,BREAK>
23000 MK<BREAKMACROS,BREAK0,BREAK1,BREAK1ERX,BRKAPPLY>
23050 MK<BRKCOMS,BRKEXP,BRKFN,BRKTYPE,BRKWHEN,BROKEN,BROKENFNS>
23100 MK<BY,C,CAIE,CAIN,CALL,CALLF,CALLF@,CAME,CAMN,CAN'T,CHANGE>
23150 MK<CHNGDFLG,CLEARB,CLEARM,COM,COM0>
23200 MK<COMS,COMSQ,COPYFLG,CPTR,D,DE,DEFSYM,DELETE,DF>
23250 MK<DIFFERENCE,DIFFERENT EXPRESSION,DM,DREVERSE,DRM,DSKIN>
23300 MK<DSKOUT,DSM,DSUBST,E,EDIT,EDIT-SAVE>
23350 MK<EDIT4E,EDIT4F,EDIT4F1,EDIT:,EDITBF,EDIT1,EDITCOMSL>
23400 MK<EDITE,EDITF,EDITFNS,EDITFPAT>
23450 MK<EDITL,EDITL0,EDITL1,EDITMACROS,EDITMBD,EDITMV>
23500 MK<EDITOPS,EDITQF,EDITRACEFN,EDITXTR,EMBED,ENTER ,ERXACTION>
23550 MK<EX,EXCH,EXTRACT,F,F=,FF,FILES-LOADED,FINDFLAG,FNDBRKPT,FOR,FOUND>
23600 MK<FROM,FROM?=,FS,FUNTYPE,G,GETSYM,GREATERP,GRINL,GVAL>
23650 MK<GWD,HERE,HLLZS@,HLRZ,HLRZ@,HRLM@,HRRM,HRRM@,HRRZ,HRRZ@,HRRZS@>
23700 MK<I,IF,IN,INSERT,INSIDE,JCALL,JCALLF,JCALLF@,JRST,JSP>
23750 MK<JUMPE,JUMPN,KLIST,L,L0,L11,L12,LAP,LAPEVAL,LAPLST,LASTAIL>
23800 MK<LASTPOS,LASTWORD,LASTP1,LASTP2,LASTVALUE,LC,LCFLG,LCL,LDIFF,LESSP>
23850 MK<LEXPR,LI,LO,LP,LPQ,LPTLENGTH,LSUBST>
23900 MK<M,MARK,MARKLST,MAX,MAXLEVEL,MAXLEVEL EXCEEDED>
23950 MK<MAXLOOP,MAXLOOP EXCEEDED,MBD,MIN,MOVE,MOVEI,MOVEM>
24000 MK<MOVNI,MV,N,N?,NAMESCHANGED,NEX,NOT BLOCKED,NOT EDITABLE>
24050 MK<NOTHING SAVED,NTH,NX,OCCURRENCES,OK,OLDPROMPT,OPS,ORF,ORR>
24100 MK<P,PLEV,PLUS,POP,POPJ,PP,PREVEV,PRINLEV,PRINTLEV>
24150 MK<PUSH,PUSHJ,PUTSYM,QLIST,QUOTIENT,R,READBUF>
24200 MK<REDEFINED,REMOVE,REPACK,REPLACE,RETFROM,RI,RO>
24250 MK<S,SAVE,SECOND,SELECTQ,SN,SOJE,SOJN>
24300 MK<START,STKCOUNT,STKNAME,STKNTH>
24350 MK<STKSRCH,STOP,SUB,SUBPAIR,SURROUND,SW>
24400 MK<TAILP,TCONC,TDZA,TEST,THIRD,THROUGH,THRU,TIMES,TO>
24450 MK<TOFLG,TOPFLG,TRACE,TRACEDFNS,TTY:,TYPE,UNBLOCK,UNBREAK>
24500 MK<UNBREAK0,UNBREAKABLEFNS,UNDEF,UNDO>
24550 MK<UNDOLST,UNDOLST1,UNDONE,UNFIND,UNTRACE,UP>
24600 MK<UPFINDFLG,USE,USERMACROS,WHEN,WITH,X,XTR,Y,ZZ>
24650 MK<@,<\>,<\#\ >,<\P>,↑,↑↑,←,←←, , , ?, . ,< . UNBOUND)>>
24700 MK<- LOCATION UNCERTAIN, = ,! ,!0,!NX,!UNDO,!VALUE,##>
24750 MK<#1,#2,#3,$%DOTFLG,%%BKPOS,%%CMDL,%%V>
24800 MK<%DEFINE,%DEREAD,%DEVP,%ERDEPTH,%LOOKDPTH,%PREVFN%>
24850 MK<%PRINFN,%READIN,&,& ,<(>,<(DEFPROP >,<)>,*,*ANY*,*RSETERX,-->
24900 MK<-IN-,::,:::,/BREAK1,:,=,==,?=,??>
24950 MK<... , ...],BINARY PROGRAM SPACE EXCEEDED>
25000 MK<NOT A TAIL - LDIFF,NO EVAL BLIP - RETFROM>
25050 MK<BAD ARGUMENT - LCONC,BAD ARGUMENT - TCONC>
25100 MK<DSK:,INIT,LSP,NOT IN SYMBOL TABLE,& UNHAPPY>
25150 MK<ARGUMENTS NOT FOUND,NOT BREAKABLE FUNCTION,ARGUMENT LIST?>
25200 MK<AROUND,BREAKIN,EDBRK,BROKEN-IN,EDVAL,DREMOVE,LCONC,SUBLIS>
25250 MK<EDITDSUBST,MAKEFN,FNDEF,LXPD,WHERE,MESS>
25300 MK<SHOULD BE LIST,SHOULD BE LIST OF ATOMIC ARGUMENTS>
25350 MK<FSUBR -- TAKES ONLY ONE ARGUMENT,UNBREAKABLE UNLESS 'IN' SOMETHING>
25400 MK<EDITV,GRINPROPS,=EDITV,EDITP,ARGS,EDITFINDP>
25450
25500 ;ATOMS OF GENERATED FUNCTIONS
25550 MK<SUBFUN1ARGPRINT,SUBFUN1BREAKIN0,SUBFUN1EDITCONT,SUBFUN1EDITL1,SUBFUN1EDOR>
25600 MK<SUBFUN1EDVAL,SUBFUN1ERRCOM>
25650 BFWS:
25700 EFWS: 0
25750 RELOC
25800 XLIST
25850 LIT
25900 LIST
25950 BHORG: 0
26000 RELOC
26050 PAGE
26100 SUBTTL LISP STORAGE ALLOCATOR (ONCE ONLY) --- PAGE 21
26150
26200
26250 ALLOC: CLEARM 0,SBPS ;SET UP INITIAL ALLOCATIONS FOR SPACE
26300 HRRZI A,BFWS-FS ;THIS IS THE SIZE OF THE ORIGINAL FS
26350 HRRZM A,SFS
26400 HRRZI A,EFWS-BFWS ;THIS ALLOWS ONLY THE INITIAL
26450 HRRZM A,SFWS ;FWS
26500 HRRZI A,0 ;THE INITIAL ALLOCATION FOR SPDL
26550 HRRZM A,SSPDL
26600 HRRZM A,SRPDL ;AND FOR RPDL IS SET UP IN INALLC
26650 HRRZI A,FS
26700 HRRZM A,FSO ;THIS SETS UP INITIAL FS POINTER
26750 HRRZI A,BFWS ;THIS SETS UP INITIAL FWS ORIGIN POINTER
26800 HRRZM A,FWSO#
26850
26900 HRRZI A,EFWS
26950 HRRZM A,EFWSO#
27000
27050
27100 MOVEI A,FS
27150 ADDM A,VBPORG ;SET UP VARIABLE FOR BPS ORIGIN
27200 SOS A
27250 ADDM A,VBPEND
27300
27350 MOVE A,JOBREL
27400 HRLM A,JOBSA
27450 CALLI RESET
27500 MOVEI A,DDT
27550 CALLI A,2 ;SET UP DDT REENTRY POINT FOR AUTOMATIC CONTROL H
27600 MOVEI A,LISPGO
27650 HRRM A,JOBSA
27700
27750 SETOM INITFW# ;FLAG FOR STANDARD INITIALIZATION OF
27800 SETZM JRELO# ;OF SIZES, AND TO INDICATE CORE WAS EXPANDED
27850
27900 JRST INALLC
27950
28000
28050 DEFINE MKENT (A)<
28100 INTERNAL A>
28150
28200 MKENT <EVBIG,NUMBP2,OPOV,NUMV2,NUMV3,NUMV4,OPR,FLOOV,FIX2>
28250 MKENT <NUM1,NUM3,BPR,FWCONS,FALSE,TRUE,FW0CNS,NCONS>
28300 MKENT <READ,READP1,MAKNUM,PRIN1,PRINT,EXPLODE,SASSOC,EQUAL,SUBST>
28350 MKENT <CHCT,LINL,OLDCH,FLATSIZE,TYI,RATOM,CHRCT,TYOD>
28400 MKENT <GET,INTERN,REMOB,MAKNAM,GENSYM,FIX,LENGTH,READLIST,PATOM>
28450 MKENT <LAST,INC,OUTC,FIX1A,NUMVAL,REVERSE,MAPLIST,GC,GETL,PUTPROP>
28500 MKENT <ERR,MAPCAR,REMPROP,LIST,SETQ,ERRSET,REMOB,ARRAY,APPEND>
28550 MKENT <SPECBIND,SPECSTR,XCONS,ATOM,READCH,SET,NCONC,PRINC>
28600 MKENT <CONS,ACONS,CTY,FP7A1,TERPRI,LSPRET>
28650 MKENT <TYO,ITYO,IGSTRT,NOINFG,CHRTAB,EVAL,OEVAL,.APPEND,INPUT,OUTPUT>
28700 IFN ALVINE,<MKENT<PSAV1,BKTRC>>
28750
28800 ;$$ FOR ALAN'S DIRECT ACCESS INPUT
28850 MKENT <ININBF,TYI2,TYIA,INCH>
28900
28950 ;$$ FOR ALVINE
29000 MKENT <PROMPT,INUM0,MEMQ,UNBOUND>
29050
29100 PAGE
29150 END ALLOC
29200